program Tetris;
uses crt, graph, windos;
const cols = 15; rows = 30;
      FieldX = 50; FieldY = 50;
      Size = 12;
type FieldType = array[1..cols ,1..rows] of byte;
     BlockType = array[-2..2, -2..2] of boolean;
     LineType = array[1..rows] of boolean;
var  Field : FieldType;
     Block, BlockTEMP : BlockType;
     BlockX, BlockY, BlockC, BlockNbr : byte;
     Ende, NoDown : boolean;
     Taste : char;

procedure Initialize;
var Gd, Gm: Integer;
begin
  randomize;
  Gd := Detect;
  InitGraph(Gd, Gm, '');
  if GraphResult <> grOk then
    Halt(1);
end;

function Time : real;
var h, m, s, hs : word;
begin
  GetTime(h,m,s,hs);
  Time := 3600*h + 60*m + s + hs/100;
end;

procedure GetKey;
begin
  IF Taste <> '_' THEN Exit;
  IF keypressed THEN Taste := readkey;
end;

function CheckTEMP : boolean;
var correct : boolean;
    x, y : integer;
begin
  correct := true;
  for x := -2 to 2 do
   for y := -2 to 2 do
    IF   BlockTEMP[x,y]
    THEN begin
         IF Field[BlockX+x,BlockY+y] <> 0 THEN correct := false;
         IF ((BlockX+x) < 1) OR ((BlockX+x) > cols) THEN correct := false;
         IF ((BlockY+y) < 1) OR ((BlockY+y) > rows) THEN correct := false;
         end;
  CheckTEMP := correct;
end;

function CheckMove(xMov, yMov : integer) : boolean;
var correct : boolean;
    x, y : integer;
begin
  correct := true;
  for x := -2 to 2 do
   for y := -2 to 2 do
    IF   Block[x,y]
    THEN begin
         IF Field[BlockX+x+xMov,BlockY+y+yMov] <> 0 THEN correct := false;
         IF ((BlockX+x+xMov) < 1) OR ((BlockX+x+xMov) > cols) THEN correct := false;
         IF ((BlockY+y+yMov) < 1) OR ((BlockY+y+yMov) > rows) THEN correct := false;
         end;
  IF (NOT correct) AND (yMov > 0) THEN NoDown := true;
  CheckMove := correct;
end;

procedure ClearField;
var x, y : integer;
begin
  for x := 1 to cols do
    for y := 1 to rows do
      Field[x,y] := 0;
end;

procedure ClearBlockTEMP;
var x, y : integer;
begin
  for x := -2 to 2 do
    for y := -2 to 2 do
      BlockTEMP[x,y] := false;
end;

procedure DrawBorder;
begin
  SetColor(15);
  MoveTo(FieldX-1,FieldY);
  LineTo(FieldX-1,FieldY+ size*rows);
  LineTo(FieldX +size*cols,FieldY+size*rows);
  LineTo(FieldX +size*cols,FieldY);
end;

procedure DrawField;
var x, y : integer;
begin
  SetFillStyle(SolidFill,0);
  Bar(FieldX,FieldY,FieldX+cols*size,FieldY+rows*size);
  DrawBorder;
  for x := 1 to cols do
   for y := 1 to rows do
    IF   Field[x,y] <> 0
    THEN begin
         SetFillStyle(SolidFill, Field[x,y]);
         Bar(FieldX+(x-1)*size,FieldY+(y-1)*size,FieldX+x*size-1,FieldY+y*size-1);
         end;
end;

procedure AddBlockToField;
var x, y : integer;
begin
  for x := -2 to 2 do
    for y := -2 to 2 do
      IF Block[x,y] THEN Field[BlockX+x,BlockY+y] := BlockC;
end;

procedure NewBlock;
var x, y : integer;
begin
  for x := -2 to 2 do
    for y := -2 to 2 do
      Block[x,y] := false;
  BlockNbr := Random(8);
  case BlockNbr of
    0 : for x := -2 to 2 do Block[x,0] := true; {#####}
    1 : for x := -1 to 2 do Block[x,0] := true; { ####}
    2..4 : begin
           for x := -1 to 1 do Block[x,0] := true;   { ### }
           Block[BlockNbr-3,1] := true;              { 234 }
           end;
    5 : for x := 0 to 1 do                      {  ## }
          for y := 0 to 1 do                    {  ## }
            Block[x,y] := true;
    6 : for x := -1 to 0 do                     { ##  }
          for y := 0 to 1 do                    {  ## }
            Block[x+y,y] := true;
    7 : for x := 0 to 1 do                      {  ## }
          for y := 0 to 1 do                    { ##  }
            Block[x-y,y] := true;
  end;
  BlockC := Random(14) + 1;
  BlockX := (cols+1) div 2;
  BlockY := 1;
  IF NOT CheckMove(0,0) THEN Ende := true;
end;

procedure DrawBlock(c : byte);
var x, y, x1, x2, y1, y2 : integer;
begin
  SetFillStyle(SolidFill,c);
  for x := -2 to 2 do
   for y := -2 to 2 do
    IF   Block[x,y]
    THEN begin
         x1 := (BlockX+x-1)*Size + FieldX;
         x2 := x1 + Size - 1;
         y1 := (BlockY+y-1)*Size + FieldY;
         y2 := y1 + Size - 1;
         Bar(x1,y1, x2,y2);
         end;
end;

procedure MoveBlock(xMov, yMov : integer);
begin
  IF   CheckMove(xMov, yMov)
  THEN begin
       DrawBlock(0);
       BlockX := BlockX + xMov;
       BlockY := BlockY + yMov;
       DrawBlock(BlockC);
       end;
end;

procedure RotateBlock;
var x, y, xT, yT : integer;
begin
  IF BlockNbr = 5 THEN Exit; {Quadrat}
  ClearBlockTEMP;
  IF   BlockNbr = 1 {####}
  THEN begin
       IF Block[0,1] {senkrecht} THEN
        for x := -1 to 2 do BlockTEMP[x,0] := true
       ELSE for y := -1 to 2 do BlockTEMP[0,y] := true;
       end;
  for x := -2 to 2 do
   for y := -2 to 2 do
    begin
      xT := y*-1; yT := x;
      BlockTEMP[xT,yT] := Block[x,y];
    end;
  IF   CheckTEMP
  THEN begin
       DrawBlock(0);
       for x := -2 to 2 do
        for y := -2 to 2 do
         Block[x,y] := BlockTEMP[x,y];
       DrawBlock(BlockC);
       end;
end;

procedure DeleteLine(Nbr : integer);
var x, y : integer;
begin
  IF   Nbr > 1
  THEN begin
       for y := Nbr downto 2 do
        for x := 1 to cols do
         Field[x,y] := Field[x,y-1];
        end;
  for x := 1 to cols do
   Field[x,1] := 0;
end;

procedure ClearLines;
var i, x, y : integer;
    LTC : LineType;
    full, continue : boolean;
begin
  continue := false;
  for y := 1 to rows do
   begin
    GetKey;
    full := true;
    for x := 1 to cols do
     IF Field[x,y] = 0 THEN full := false;
     LTC[y] := full; IF full THEN continue := true;
   end;
  IF NOT continue THEN Exit;
  for i := 1 to 4 do
  begin
   for y := 1 to rows do
    IF   LTC[y]
    THEN begin
         IF i mod 1 = 1 THEN SetFillStyle(SolidFill,15) ELSE SetFillStyle(SolidFill,0);
         Bar(FieldX,FieldY+(y-1)*size,FieldX+cols*size,FieldY+y*size);
         end;
  Delay(300);
  end;
  for y := 1 to rows do
    IF LTC[y] THEN DeleteLine(y);
  DrawField;
end;
procedure Main;
var LastCycle, Speed : real;
    Drop : boolean;
begin
  Ende := false; Taste := '_'; Speed := 0.5;
  ClearDevice; ClearField; DrawBorder; NewBlock;
  repeat
   LastCycle := Time;
   repeat
    Drop := false;
    GetKey;
    case Taste of
      'a', 'j' : MoveBlock(-1,0);
      'd', 'l' : MoveBlock(1,0);
      's', 'k' : Drop := true;
      'w', 'i' : RotateBlock;
      'q' : Ende := true;
    end;
    Taste := '_';
   until (Time >= LastCycle + Speed) OR Drop;
   repeat
     NoDown := false;
     MoveBlock(0,1);
     IF   NoDown
     THEN begin
          AddBlockToField;
          NewBlock;
          Drop := false;
          end;
   until NOT Drop;
   ClearLines;
  until Ende;
end;

begin
  Initialize;
  Main;
end.