Старый добрый тетрис

{ Программа Тетрис}
 
uses crt, graph;
 
type tFigure=array[1..4,1..4] of byte;
     tFigures=array[1..7,1..4] of tFigure;
     tColors=record
       workbox:byte;
       figures:array[1..7] of byte;
     end;
 
Const HeightBox=18; WidthBox=9; { размеры стакана }
 
var Figures:^tFigures; Colors:tColors;
 
Procedure LoadFigures; { чтение фигур из файла }
var f:text; s:string; i,j,k,l:byte;
begin
  assign(f,'c:\tetris.dat'); reset(f);
  for j:=1 to 7 do
    for i:=1 to 4 do
      for k:=1 to 4 do begin
        readln(f,s);
        for l:=1 to 4 do if s[l]='1' then Figures^[j,i,k,l]:=1 else Figures^[j,i,k,l]:=0;
  end;
  close(f);
end;
 
Procedure Game(x,y:byte);
var box:array[1..HeightBox+1,0..WidthBox+1] of byte; { стакан }
    num,rot,xf,yf:integer; { тип фигуры, ее положение и координаты }
    c:char;
    i,j,k:integer;
 
    Lines:word; { кол-во убраных линий }
    Speed:Word; { скорость - чем меньше, тем быстрее }
 
    timer:longint absolute $40:$6c; old:longint; { для реализации задержки }
 
Procedure PutBox; { вывод стакана }
var i,j:integer;
begin
  for i:=1 to HeightBox do begin
    gotoxy(x+1,y+i);
    for j:=1 to WidthBox do begin
      textattr:=box[i,j];
      if box[i,j]=0 then textattr:=colors.workbox;
      write('  ');
    end;
  end;
end;
 
Procedure PutFigure; { вывод фигуры }
var i,j:integer;
begin
  textattr:=colors.figures[num];
  for i:=1 to 4 do begin
    for j:=1 to 4 do begin
      if Figures^[num,rot,i,j]=1 then begin
        gotoxy(x+1+xf*2+pred(j)*2,y+i+pred(yf)); write('  ');
      end;
    end;
  end;
end;
 
Function Check(dx,dy:shortint):boolean; { проверка может ли фигура сместиться
                                          по dx,dy }
var i,j:integer; ok:boolean;
begin
  ok:=true;
  for i:=1 to 4 do for j:=1 to 4 do
    if figures^[num,rot,i,j]=1 then
      if box[yf+pred(i)+dy,xf+j+dx]>0 then ok:=false;
  Check:=ok;
end;
 
Procedure Loser; { что будет в случае проигрывания }
begin
  textattr:=7; clrscr;
  writeln('вы проиграли набрав ',lines,' полных линий');
  readkey;
  c:=#27;
end;
 
begin
  x:=pred(x); y:=pred(y);
  textattr:=colors.workbox;
 
  fillchar(box,sizeof(box),0); { очистка стакана }
  { задание границ движений фигуры }
  for i:=1 to HeightBox do begin box[i,0]:=2; box[i,WidthBox+1]:=2 end;
  for j:=0 to WidthBox+1 do box[HeightBox+1,j]:=2;
 
  Randomize;
 
  Speed:=36; { установка задержки до опускания фигуры вниз примерно на
               2 секунды ( генерация 18.2 раза в секунду * 2секунды = ~36 ) }
  lines:=0;  { убраных линий нет }
 
  { The GAME }
  num:=random(7)+1; rot:=1; xf:=WidthBox div 2-2; yf:=1;
  old:=timer;
  repeat
    PutBox; { выводим стаканчик }
    PutFigure; { выводим фигуру }
    gotoxy(80,25); { убираем курсор }
    repeat until keypressed or (abs(old-timer)>speed);
    { обработка клавиатуры }
    if keypressed then begin
      c:=readkey;
      if c=#0 then case readkey of
        #72:begin { поворот фигуры }
              inc(rot); if rot=5 then rot:=1;  { произвели поворот }
              if not check(0,0) then begin { проверка на невозможность }
                dec(rot); if rot=0 then rot:=4; { вернули все обратно }
              end;
            end;
        #75:if Check(-1,0) then dec(xf); { сдвиг влево }
        #77:if Check(1,0) then inc(xf);  { сдвиг вправо }
        #80:begin                        { падение фигуры }
              while Check(0,1) do inc(yf); { фигура движется вниз пока возможно }
 
              for i:=1 to 4 do for j:=1 to 4 do { оставляем след фигуры в стакане }
                if figures^[num,rot,i,j]=1 then
                  box[yf+pred(i),xf+j]:=colors.figures[num];
 
              { генерируем новую фигуру }
              num:=random(7)+1; rot:=1; xf:=WidthBox div 2-2; yf:=1;
 
              { проверка стакана на наличие полных линий }
              for i:=1 to HeightBox do begin
                k:=0;
                for j:=1 to WidthBox do if box[i,j]>0 then inc(k);
                if k=WidthBox then begin { линия заполнена }
                  inc(Lines); { увеличиваем счет}
                  { удаляем линию }
                  for k:=i downto 2 do for j:=1 to WidthBox do box[k,j]:=box[pred(k),j];
                end;
              end;
 
              if not check(0,0) then loser; { если новой фигуре негде
                 появиться, то проигрыш }
            end;
      end;
    end else
    { обработка прошедшего времени }
    begin
      { если возможно, то сдвигаем фигуру вниз }
      if Check(0,1) then inc(yf) else begin { иначе... }
        { оставляем след фигуры в стакане }
        for i:=1 to 4 do for j:=1 to 4 do
          if figures^[num,rot,i,j]=1 then box[yf+pred(i),xf+j]:=colors.figures[num];
 
        { генерируем новую фигуру }
        num:=random(7)+1; rot:=1; xf:=WidthBox div 2-2; yf:=1;
 
        { проверка стакана на наличие полных линий }
        for i:=1 to HeightBox do begin
          k:=0;
          for j:=1 to WidthBox do if box[i,j]>0 then inc(k);
          if k=WidthBox then begin
            inc(Lines);
            for k:=i downto 2 do for j:=1 to WidthBox do box[k,j]:=box[pred(k),j];
          end;
        end;
 
        if not check(0,0) then loser; { если новой фигуре негде
           появиться, то проигрыш }
      end;
      old:=timer;
    end;
  until c=#27;
end;
 
var i:byte;
begin
  textattr:=7; clrscr;
  New(Figures);
  with Colors do begin
    workbox:=7*16;
    for i:=1 to 7 do figures[i]:=16*pred(i);
    figures[1]:=6*16;
  end;
  LoadFigures;
  Game(2,2);
 
  textattr:=7; clrscr;
end.