Игра Тетрис на PascalABC.NET

[canadamoscow]

Игра Тетрис на PascalABC.NET

[canadamoscow]

Тетрис (часть 1)

{$apptype windows}
uses GraphWPF;

var
  Status, //0 - затирание фигуры, 1 - рисование фигуры, 2 - рисование грани стакана
            //3 - проверка перечесения/наложения, 4 - фигуру сделать частью общей кучи кирпичей
            //5 - вывод след.фигуры
  NumberFigure, //номер фигуры из имеющихся фигур
  pause, //скорость падения
  lin, //кол-во собранных(удаленных) линий
  x, y, //координаты центрального квадрата фигуры
  ColorNF, //порядковый номер цвета фигуры 
  kd : integer; //нажатая клавиша keydown
  zona: boolean; //пересечение клетки фигуры с зоной (гранью стакана или кирпичем в стакане)
  st:array[1..12, 1..22] of integer; //массив игрового поля 12х22 под именем st[12х22]

//рисует в определенной координате текстового экрана клетку фигуры или грань стакана
//проверяет пересечение клетки фигуры с зоной (гранью стакана или кирпичем в стакане)
procedure k(i,j: integer); //обработка kлетки фигуры с индексом в стакане (x,y) в соответствии со Status'ом
Const ColorN: array of Color = (Colors.White, Colors.Peru, Colors.DarkSalmon, Colors.IndianRed, 
              Colors.Gray, Colors.OliveDrab, Colors.MediumVioletRed, Colors.SteelBlue, Colors.RosyBrown);
begin
 if j > 22 then begin if (i<2) or (i>11) then Zona:=true; exit; end;//обработка клеток фигуры вне стакана
 var (xx, yy) := (220 + i*26, 573-j*26); //координаты клетки на экране
 case Status of
 0: FillRectangle(xx, yy, 26, 26, Colors.White); //Заливка клетки фигуры цветом фона
 1: FillRectangle(xx+1, yy+1, 24, 24, ColorN[st[i,j]>0 ? st[i,j] : ColorNF]); //Вывод цветной клетки/квадратика
 2: FillRectangle(xx,yy,26,26,Colors.DarkCyan); //Вывод грани стакана 
 3: if (i > 11) or (st[i,j] > 0) then zona:= true;//достигнута граница стакана или кирпичи в стакане?
 4: st[i,j] := ColorNF;    // Status 4 → записать Клетку фигуры в массив элементов стакана st:array[1..12,1..22]
 5: FillRectangle(xx-155, yy-420, 24, 24, ColorN[ColorNF]);
 end;
end;

  // Процедура fig(x,y,n,s) хранит информацию о типах фигур Тетриса
procedure fig(x,y,n,s:integer); {Рисуем фигуру}
begin
 if s = 3 then zona:= false; //s = 3 - обнуляем zona для дальнейше проверки по Status'у = 3;
 Redraw(() -> begin
 Status := s; k(x,y); //обработка центральной клетки фигуры
 case n of //обработка клеток соседних  от центральной в соответствии с текущей фигурой

// [][]
// [][]
 1: begin k(x+1,y); k(x,y-1); k(x+1,y-1) end;

// [][][][]
 2: begin k(x-1,y); k(x+1,y); k(x+2,y) end;

 // []
 // []
 // []
 // []
 3: begin k(x,y+1); k(x,y-1); k(x,y-2) end;

 // []
 // [][][]
 4: begin k(x+1,y); k(x-1,y); k(x-1,y+1) end;

 // [][]
 // []
 // []
 5: begin k(x,y+1); k(x+1,y+1); k(x,y-1) end;
 
 // [][][]
 //      []
 6: begin k(x-1,y); k(x+1,y); k(x+1,y-1) end;
 
 //   []
 //   []
 // [][]
 7: begin k(x,y+1); k(x,y-1); k(x-1,y-1) end;
 
 //      []
 // [][][]
 8: begin k(x-1,y); k(x+1,y); k(x+1,y+1) end;

 // []
 // []
 // [][]
 9: begin k(x,y+1); k(x,y-1); k(x+1,y-1) end;

 // [][][]
 // []
 10: begin k(x+1,y); k(x-1,y); k(x-1,y-1) end;
 
  // [][]
 //    []
 //    []
 11: begin k(x,y+1); k(x,y-1); k(x-1,y+1) end;
 
  // [][]
 //    [][]
 12: begin k(x-1,y); k(x,y-1); k(x+1,y-1) end;
 
 //   []
 // [][]
 // []
 13: begin k(x,y+1); k(x-1,y); k(x-1,y-1) end;

 //   [][]
 // [][]
 14: begin k(x+1,y); k(x-1,y-1); k(x,y-1) end;
 
 // []
 // [][]
 //   []
 15: begin k(x-1,y); k(x,y-1); k(x-1,y+1) end;
 
 //   []
 // [][][]
 16: begin k(x+1,y); k(x-1,y); k(x,y+1) end;
 
 // []
 // [][]
 // []
 17: begin k(x+1,y); k(x,y+1); k(x,y-1) end;
 
 // [][][]
 //   []
 18: begin k(x,y-1); k(x-1,y); k(x+1,y) end;
 
 //   []
 // [][]
 //   []
 19: begin k(x-1,y); k(x,y+1); k(x,y-1) end
 end
end)
end;

//перемещение фигуры с помощью клавиатуры
procedure dvig;
begin
 sleep(pause); // Задержка при падении
 case kd of  
  1: begin
        fig(x-1,y,NumberFigure,3);
        if not zona then begin fig(x,y,NumberFigure,0); x -= 1; fig(x,y,NumberFigure,1); end;
       end;
  3: begin
         fig(x+1,y,NumberFigure,3);
         if not zona then begin fig(x,y,NumberFigure,0); x:=x+1; fig(x,y,NumberFigure,1); end;
       end;
  5: begin
          var povorot := Procedure → //цикличное вращение фигуры
           begin
            NumberFigure -= 1;
            case NumberFigure of 
             15: NumberFigure:=19;
             13: NumberFigure:=15;
             11: NumberFigure:=13;
              7: NumberFigure:=11;
              3: NumberFigure:=7;
              1: NumberFigure:=3;
              0: NumberFigure:=1;
            end;
         end;
        //поворот, проверка на наложение/пересечение, еще трижды повернули до исходного положения
         povorot; fig(x,y,NumberFigure,3); povorot; povorot; povorot;
        //если проверка пройдена то вращаем с выводом на экран
         if not zona then begin fig(x,y,NumberFigure,0); povorot; fig(x,y,NumberFigure,1); end;
      end;
  2: pause:=2; //ускоренное падение фигуры
  22: pause := 100 - lin * 2;//запланировання скорость падения
end;
end;

[canadamoscow]

Тетрис (часть 2)

//Основная программа
procedure Main;
label Zero; //Метка  "игра с нуля"
begin
zero:
Window.Clear(Colors.White);
TextOut(45,10, 'Следующая:', Font.withSize(24).withColor(Colors.DarkBlue));
TextOut(25,380, 'Enter - новая игра', Font.withSize(22).withColor(Colors.DarkRed));
TextOut(25,410, 'Курсоры - для игры', Font.withSize(20).withColor(Colors.DarkBlue));
//стена вокруг стакана
 for var xx:=1 to 12 do for var yy:=1 to 22 do 
   if (xx=1)or(xx=12)or(yy=1) then 
     begin st[xx,yy]:=1; Status := 2; k(xx,yy) end //Рисуем контур стакана
   else st[xx,yy]:= 0; //обнуляем содержимое стакана
 zona := false; 
 Status := 0;
 kd := 0;
 lin:=0; //количество уже собранных(удаленных) линий
 var nextF := (1+random(18), Random(1,8));
 FillRectangle(30,220,200,140,Colors.White);
 DrawText(30,220,200,140,'Линии: 0', Colors.DarkBlue);
 repeat
  pause := 100 - lin * 2; // когда d = 170 - это очень медленно, когда 10 - то быстровато!
  FillRectangle(70,60,160,140,Colors.White);//очищаем зону предпросмотра
  var Now := NextF;//сохраняем новую текущую фигуру и её цвет
  nextF := (1+random(18), Random(1,8));// следующая фигура и её цвет
  Status := 5; (NumberFigure, ColorNF):= nextF;  //подготовка и
  fig(2,2,NumberFigure,5);//вывод следующей фигуры в предпросмотр
  Status := 0; (NumberFigure, ColorNF):= Now; //Возврат к текущей фигуре
  (x,y) := (7, 22); //индекc появления новой фигуры
  fig(x,y,NumberFigure,3); //проверка перед перемещением на пересечение каждой клетки фигуры
                                        //со стенкой или уложенными кирпичами и
  if not zona then //если нет пересечения со стаканом или уложенными кирпичиками, то
  begin
    repeat // повторять до столкновения
     fig(x,y,NumberFigure,1); // Рисуется текущая фигура
     loop 15 do begin dvig; if kd = 10 then goto Zero; kd := 0; end; //скан и обработка нажатия клавиши
     fig(x,y-1,NumberFigure,3); //Проверка фигуры со смещением по оси Y на пересечение со стенкой или кирпичами
     if not zona then begin fig(x,y,NumberFigure,0); y -= 1 end;//Закрашиваем фигуру цветом фона
    until zona;  // Столкновение произошло
    fig(x,y,NumberFigure,4); { Нарисовать текущую фигуру, которая не может двигаться и записать её положение 
                         в массив кирпичей стакана st[,] }
    Redraw(() ->begin
    for var yy := 22 downto 2 do // Проверка заполненных линий
     begin
       var a:=0; for var xx:=2 to 11 do a += st[xx,yy]>0 ? 1 : 0; //Счетчик заполнения линии кирпичами
       if a=10 then //Если сумма кирпичей 10 (линия собрана),его нужно удалить, а кирпичи стакана сдвинуть вниз
       begin  //Начало сдвига массива
         for var yyy:= yy to 21 do for var xx:= 2 to 11 do st[xx,yyy] := st[xx,yyy+1]; //Сдвиг массива вниз
         lin += 1; //счетчик собранных линий +1 и увеличть скорость игры
         FillRectangle(30,220,200,140,Colors.White);
         DrawText(30,220,200,140,'Линий: '+lin.ToString, Colors.DarkBlue);
       end // Конец сдвига массива
     end;//Конец проверки заполненных рядов

     //Перерисовать содержимое стакана после удаления линии
     for var xx:=2 to 11 do for var yy:=2 to 22 do begin Status := st[xx,yy]>0 ? 1 : 0; k(xx,yy) end;
     zona := false; 
     end);     
   end;   
 until zona; //Остановить повторение основного игрового цикла! Т.к. нет пустово места. 
   fig(x,y,NumberFigure,1);
   FillRectangle(152,300,260,100,Colors.DarkGray);  
   DrawText(152,300,260,50,'Игра окончена',Colors.DarkRed);
   DrawText(152,350,260,50,'Жми ENTER',Colors.DarkRed);
   repeat
    sleep(300); 
    if kd = 10 then goto Zero;
   until false;
end;

{Главная программа}
begin
 Window.Title := 'Тетрис';
 window.SetSize(550, 573);
 Window.CenterOnScreen; 
 Window.IsFixedSize := True; 
 Font.Style := Bold; 
 Font.Size := 32;
 OnkeyDown := K ->
  case K of
    Key.Left, Key.A: kd := 1;//влево
    Key.Down, Key.Space, Key.S: kd := 2; //ускоренное падение фигуры
    Key.Right, Key.D: kd := 3;//вправо
    Key.Up, Key.W: kd := 5; //вращение
    Key.Enter: kd := 10; //новая игра
    Key.Escape: halt(1); //выход
   else kd := 0; 
 end; 
 OnkeyUp := K ->
    case k of
      Key.Down, Key.Space, Key.S: kd := 22; //обычное падение фигуры
    end;
 Main;
end.

[NetSpace]

держи. тут есть фишки, типа белой, чёрной и серой точки, которые кое-чего дополняют.
фигуры разного уровня сложности. 20 уровней от низа стакана.
вдруг, чего нового добавишь.

[Arigato]

Фигуры проще было через массив задать.

[canadamoscow]

Чуток подкорретировал