From 8987b96aeb0937290320e6d9ed2e18ff706f3723 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 10 Apr 2026 09:56:05 +0200 Subject: =?UTF-8?q?=D0=97=D0=B0=D0=BA=D0=BE=D0=BD=D1=87=D0=B8=D0=BB=20?= =?UTF-8?q?=D1=82=D0=B5=D1=82=D1=80=D0=B8=D1=81=20=D0=B8=D0=B7=207-=D0=B9?= =?UTF-8?q?=20=D0=B3=D0=BB=D0=B0=D0=B2=D1=8B,=20=D1=88=D0=B5=D1=81=D1=82?= =?UTF-8?q?=D0=BE=D0=B3=D0=BE=20=D1=83=D0=BF=D1=80=D0=B0=D0=B6=D0=BD=D0=B5?= =?UTF-8?q?=D0=BD=D0=B8=D1=8F?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../7/6_tetris/Unit1.pas" | 438 +++++++++++++++++++++ 1 file changed, 438 insertions(+) create mode 100644 "\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/7/6_tetris/Unit1.pas" (limited to 'Занимательное программирование/7/6_tetris/Unit1.pas') diff --git "a/\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/7/6_tetris/Unit1.pas" "b/\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/7/6_tetris/Unit1.pas" new file mode 100644 index 0000000..91fd894 --- /dev/null +++ "b/\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/7/6_tetris/Unit1.pas" @@ -0,0 +1,438 @@ +unit Unit1; + +{$MODE objfpc}{$H+} + +interface + +uses + LCLType, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls, StdCtrls, + Unit2, Math, Dialogs; + +type + + { TForm1 } + + TForm1 = class(TForm) + Label2: TLabel; + ScoreLabel: TLabel; + Screen: TImage; + ImageList: TImageList; + BackBuffer: TImage; + Label1: TLabel; + LinesLabel: TLabel; + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); + + private + { Private declarations } + public + { Public declarations } + end; + + TGameHandler = class(TInterfacedObject, IGameHandler) + private + Finished: Boolean; + public + CurX, CurY: Integer; { координаты текущей фигуры } + CurPiece: Integer; { ее идентификатор } + CurColour: Integer; { и цвет } + v: Integer; { счетчик кадров } + + constructor Create; + + procedure DoIteration; + procedure Reset; + procedure Finish; + function IsFinished: Boolean; + end; + +var + Form1: TForm1; + ActionThread: TActionThread; + Lines, Score: Integer; { количество собранных линий } + Level: Integer; + +implementation + +{$R *.lfm} + +{ поворот фигуры на 90 градусов } +procedure Rotate90(piece : Integer); +var + i, j: Integer; + temp: array[0..3, 0..3] of Integer; { "временная" фигура } +begin + for i := 0 to 3 do { поворот на 90 градусов по часовой стрелке } + for j := 0 to 3 do + temp[3 - j, i] := Pieces[piece, i, j]; + + for i := 0 to 3 do { копируем измененную фигуру в исходный массив } + for j := 0 to 3 do + Pieces[piece, i, j] := temp[i, j] +end; + +{ сдвиг фигуры в угол } +procedure ToCorner(piece : Integer); +var + i, j: Integer; +label exit1, exit2; +begin + { цикл вертикального сдвига } + while true do + begin + for i := 0 to 3 do { если больше не надо двигать вверх } + if Pieces[piece, i, 0] = 1 then + { переходим к горизонтальному сдвигу } + goto exit1; + { иначе сдвигаем на клетку вверх } + for i := 0 to 3 do + for j := 0 to 2 do + Pieces[piece, i, j] := Pieces[piece, i, j + 1]; + + for i := 0 to 3 do + Pieces[piece, i, 3] := 0; { нижний ряд заполняем нулями } + end; + +exit1: { аналогично: } + while true do { цикл горизонтального сдвига } + begin + for j := 0 to 3 do { если больше не надо двигать влево } + if Pieces[piece, 0, j] = 1 then + goto exit2; { выход } + + for j := 0 to 3 do { иначе сдвигаем на клетку влево } + for i := 0 to 2 do + Pieces[piece, i, j] := Pieces[piece, i + 1, j]; + + for j := 0 to 3 do + Pieces[piece, 3, j] := 0; { правый ряд заполняем нулями } + end; + +exit2: { конец работы } +end; + +{ загрузить "строительные блоки" } +procedure LoadBitmaps; +var + i: Integer; +begin + for i := 0 to 4 do + begin + Bitmaps[i] := TBitmap.Create; + Form1.ImageList.GetBitmap(i, Bitmaps[i]) + end +end; + +{ освободить память } +procedure FreeBitmaps; +var + i: Integer; +begin + for i := 0 to 4 do + Bitmaps[i].Free +end; + +{ инициализация игрового поля } +procedure InitField; +var + i, j: Integer; +begin + { Заполняем собственно поле нулями } + { (соответствующими свободному пространству). } + for i := 0 to FieldWidth - 1 do + for j := 0 to FieldHeight - 1 do + begin + Field[i, j] := 0; + { Очистка экрана. } + Form1.BackBuffer.Canvas.Draw(22*i, 22*j, Bitmaps[0]) + end; + + { Помечаем участки, находящиеся под "стаканом", как занятые. } + for i := 0 to FieldWidth - 1 do + Field[i, FieldHeight] := 1; + + { Таким же образом помечаем участки слева и справа от поля. } + for j := 0 to FieldHeight do + begin + Field[-1, j] := 1; + Field[FieldWidth, j] := 1 + end +end; + +procedure InitLevel(ALevel: Integer); +begin + InitField; { очистка игрового поля } + { Пока не собрано ни одной линии. } + Lines := 0; + Level := ALevel +end; + +{ Рисование фигуры. } +procedure DrawPiece(x, y, piece, colour : Integer); +var + i, j: Integer; +begin + for i := 0 to 3 do + for j := 0 to 3 do + if Pieces[piece, i, j] = 1 then + begin + { рисуем очередной "строительный блок" } + Form1.BackBuffer.Canvas.Draw(22*(x + i), 22*(y + j), Bitmaps[colour]); + Field[x + i, y + j] := colour { вносим изменения в игровое поле } + end +end; + +{-------------------------------------------------------------} +{ Можно ли поместить фигуру в (x, y)? } +function CanPlace(x, y, piece : Integer) : Boolean; +var + i, j: Integer; +begin + for i := 0 to 3 do + for j := 0 to 3 do + if (Pieces[piece, i, j] = 1) and (Field[x + i, y + j] <> 0) then + begin + CanPlace := false; { участок фигуры накладывается на } + Exit { занятую клетку поля; запрещаем действие } + end; + CanPlace := true { пересечений не обнаружено } +end; + +{ Сдвиг поля (уничтожение линий). } +procedure ShiftField; +var + i, j: Integer; + fullrow: Boolean; + curline: Integer; + LinesAtOnce: Integer; +begin + curline := FieldHeight - 1; { текущая линия (начинаем с нижней) } + LinesAtOnce := 0; + { Идем до самого верха. } + while curline >= 0 do + begin + { Определяем, собрана линия целиком или нет. } + fullrow := true; + for i := 0 to FieldWidth - 1 do + { Если поле в текущей строке содержит } + { хотя бы один нуль, линия не собрана } + if Field[i, curline] = 0 then + begin + fullrow := false; + Break + end; + + { если линия собрана } + if fullrow then + begin + { Увеличиваем кол-во собранных линий. } + Inc(LinesAtOnce); + + for i := 0 to FieldWidth - 1 do { сдвигаем верхнюю часть } + for j := curline downto 1 do { поля вниз } + Field[i, j] := Field[i, j - 1]; + + { сдвигаем вниз также изображение на экране } + Form1.BackBuffer.Canvas.CopyRect(Rect(0, 22, 220, 22*(curline+1)), + Form1.BackBuffer.Canvas, Rect(0, 0, 220, 22*(curline))); + + { Самая верхняя строка поля теперь пуста. } + for i := 0 to FieldWidth - 1 do + begin + Field[i, 0] := 0; { заполняем ее нулями } + { на экране нулям соответствует фоновый цвет } + Form1.BackBuffer.Canvas.Draw(22*i, 0, Bitmaps[0]) + end; + end + else + { Если линия не собрана, переходим к следующей. } + curline := curline - 1 + end; + Inc(Lines, LinesAtOnce); + if LinesAtOnce = 1 then + Inc(Score, 1) + else if LinesAtOnce = 2 then + Inc(Score, 3) + else if LinesAtOnce = 3 then + Inc(Score, 5) + else if LinesAtOnce >= 4 then + Inc(Score, 7) +end; + +{-------------------------------------------------------------} + +procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + case Key of + VK_SPACE: + Key_Space := true; + VK_LEFT: + Key_Left := true; + VK_RIGHT: + Key_Right := true; + VK_DOWN: + Key_Down := true + end +end; + +{-------------------------------------------------------------} +procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + case Key of + VK_SPACE: + Key_Space := false; + VK_LEFT: + Key_Left := false; + VK_RIGHT: + Key_Right := false; + VK_DOWN: + Key_Down := false + end +end; + +{-------------------------------------------------------------} +procedure TForm1.FormCreate(Sender: TObject); +var + GameHandler: TGameHandler; +begin + Randomize; + LoadBitmaps; { загрузка "строительных блоков" } + + GameHandler := TGameHandler.Create; + + Key_Space := false; { считаем, что клавиши изначально не нажаты } + Key_Left := false; + Key_Right := false; + Key_Down := false; + + ActionThread := TActionThread.Create(GameHandler); + Score := 0; + InitLevel(1) +end; + +procedure TForm1.FormDestroy(Sender: TObject); +begin + ActionThread.GameHandler.Finish; + ActionThread.WaitFor; + FreeAndNil(ActionThread); + + FreeBitmaps { освобождение памяти } +end; + +constructor TGameHandler.Create; +begin + Finished := false; + Reset +end; + +procedure TGameHandler.DoIteration; +begin + if Lines > LinesPerLevel then + begin + SuspendThread(ActionThread.ThreadID); + ShowMessage('Переход на уровень ' + IntToStr(Level + 1)); + InitLevel(Level + 1); + Reset; + ResumeThread(ActionThread.ThreadID); + Exit + end; + if CurY = -1 then { если на экране нет движущихся фигур } + begin + CurY := 0; { создаем новую фигуру } + CurX := FieldWidth div 2; { в верхней части экрана } + CurPiece := 1 + Random(7); { ее тип и цвет выбираются } + CurColour := 1 + Random(4); { случайным образом } + + { если ее нельзя разместить, конец игры } + if not CanPlace(CurX, CurY, CurPiece) then + begin + Finish; + Exit + end + end; + + DrawPiece(CurX, CurY, CurPiece, 0); { стираем фигуру с экрана } + + { если нажата клавиша "вниз", увеличиваем скорость игры } + if Key_Down then + MSecsPerFrame := 20 + else + MSecsPerFrame := 100; + + if Key_Left and CanPlace(CurX - 1, CurY, CurPiece) then + CurX := CurX - 1; { сдвиг фигуры влево } + if Key_Right and CanPlace(CurX + 1, CurY, CurPiece) then + CurX := CurX + 1; { сдвиг фигуры вправо } + + if Key_Space then { поворот фигуры } + begin + Rotate90(CurPiece); { поворачиваем на 90 градусов } + ToCorner(CurPiece); + { Если фигуру нельзя разместить возвращаем ее } + { в первоначальное положение (повернуть еще три раза). } + if not CanPlace(CurX, CurY, CurPiece) then + begin + Rotate90(CurPiece); + Rotate90(CurPiece); + Rotate90(CurPiece); + ToCorner(CurPiece) + end + end; + + v := v + 1; { увеличиваем счетчик кадров } + + { Если на текущей итерации нет вертикального сдвига. } + if v <> Max(1, Delay - Level) then + DrawPiece(CurX, CurY, CurPiece, CurColour) + else + { Рисуем фигуру иначе. } + begin + v := 0; { обнуляем счетчик } + if CanPlace(CurX, CurY + 1, CurPiece) then + begin + CurY := CurY + 1; { если фигуру можно разместить } + DrawPiece(CurX, CurY, CurPiece, CurColour) { размещаем } + end + else { иначе } + begin + { оставляем на прежнем месте } + DrawPiece(CurX, CurY, CurPiece, CurColour); + ShiftField; { уничтожаем собранные линии } + CurY := -1 { на экране больше нет движущихся фигур } + end + end; + + { Обновляем содержимое экрана (копируем буфер на экран). } + Form1.Screen.Canvas.CopyRect(Rect(0, 0, 220, 440), + Form1.BackBuffer.Canvas, Rect(0, 0, 220, 440)); + + { Обновляем индикатор количества собранных линий. } + Form1.LinesLabel.Caption := IntToStr(Lines); + Form1.ScoreLabel.Caption := IntToStr(Score) +end; + +procedure TGameHandler.Reset; +begin + { Текущее значение Y-координаты, равное -1 служит индикатором } + { отсутствия движущихся фигур инициализация переменных. } + CurY := -1; + + v := 0; + CurPiece := 0; + CurX := 0; + CurColour := 0 +end; + +procedure TGameHandler.Finish; +begin + Finished := true +end; + +function TGameHandler.IsFinished: Boolean; +begin + Result := Finished +end; + +end. -- cgit v1.2.3