From cdc4d52b08ae1bfc1347a94f001409f38fcc575e Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 19 Mar 2026 18:45:31 +0100 Subject: =?UTF-8?q?=D0=9C=D0=B8=D0=B3=D1=80=D0=B8=D1=80=D0=BE=D0=B2=D0=B0?= =?UTF-8?q?=D0=BD=20sokoban=20=D0=BF=D1=80=D0=BE=D0=B5=D0=BA=D1=82=20?= =?UTF-8?q?=D1=81=20=D0=B4=D0=B5=D0=BB=D1=8C=D1=84=D0=B8=20=D0=B2=20lazaru?= =?UTF-8?q?s?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../7/3_sokoban/Unit1.pas" | 271 +++++++++++++++++++++ 1 file changed, 271 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/3_sokoban/Unit1.pas" (limited to 'Занимательное программирование/7/3_sokoban/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/3_sokoban/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/3_sokoban/Unit1.pas" new file mode 100644 index 0000000..bdb2a92 --- /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/3_sokoban/Unit1.pas" @@ -0,0 +1,271 @@ +unit Unit1; + +{$MODE objfpc}{$H+} + +interface + +uses + LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, ExtCtrls, Menus, ImgList; + +type + TForm1 = class(TForm) + MainMenu: TMainMenu; + FileMenu: TMenuItem; + ItemOpen: TMenuItem; + ItemExit: TMenuItem; + Screen: TImage; + ImageList: TImageList; + OpenDialog: TOpenDialog; + BackBuffer: TImage; + procedure ItemExitClick(Sender: TObject); + procedure ItemOpenClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + private + { Private declarations } + public + { Public declarations } + end; + +const + WALL = 11; SPACE = 10; BOULDER = 1; + SL = 14; SR = 15; SU = 12; SD = 13; { Индексы спрайтов. } + BOULDER_SET = ['a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i']; + PLACE_SET = ['1', '2', '3', '4', '5', '6', '7', '8', '9']; +var + Form1: TForm1; + Field: array[1..20, 1..12] of Integer; { Игровое поле. } + Places: array[1..20, 1..12] of Integer; { Положение мест. } + PlaceCount: Integer; { Общее число мест на уровне. } + CurX, CurY: Integer; { Текущее положение Сокобана. } + Positioned: Integer; { Количество размещенных камней. } + Busy: Boolean = false; { Статус обработчика клавиш. } + +implementation + +{$R *.lfm} + +{ Перевод символа в порядковый номер картинки. } +function SymbolToCode(c: Char): Integer; +begin + case c of + 'x': SymbolToCode := WALL; { 'x' - стена } + ' ': SymbolToCode := SPACE; { ' ' - пустое пространство } + 's': SymbolToCode := SL; { 's' - стартовая локация } + else + SymbolToCode := -1 { Неизвестный символ. } + end; +end; + +{ Загрузить уровень из файла. } +procedure LoadLevel(FileName: String); +var f: File of Char; + i, j : Integer; + c: Char; +begin + AssignFile(f, FileName); { Открыть файл. } + Reset(f); + + PlaceCount := 0; { Подсчет количества мест. } + for j := 1 to 12 do { Цикл по строкам. } + begin + for i := 1 to 20 do { Цикл по элементам строки. } + begin + Read(f, c); { Считаем текущий эелемент } + if c in PLACE_SET then { если это "место" } + begin + Field[i, j] := SPACE; { в поле равнозначно пустому элементу } + VAL(c, Places[i, j]); { True в массиве Places } + Inc(PlaceCount) + end + else if c in BOULDER_SET then + begin + Places[i, j] := 0; + Field[i, j] := ORD(c) - ORD('`') + end + else + begin + Places[i, j] := 0; { иначе НЕ "место" } + Field[i, j] := SymbolToCode(c); { определяем код элемента } + + if c = 's' then { если текущая локация - } + begin { стартовая, запоминаем } + CurX := i; { ее координаты } + CurY := j + end + end + end; + Read(f, c); { считываем и пропускаем возврат каретки } + Read(f, c) { считываем и пропускаем перевод строки } + end; + + CloseFile(f) { закрыть файл } +end; + +{ Перерисовка уровня. } +procedure RedrawField; +var + i, j: Integer; + code: Integer; + bitmap: TBitmap; + ScreenRect: TRect; +begin + bitmap := TBitmap.Create; { объект для временного хранения рисунка } + Positioned := 0; { считаем, что размещено 0 камней } + + for j := 1 to 12 do + for i := 1 to 20 do + begin + code := Field[i, j]; { код текущего элемента } + + { Пара "пустое пространство" / "место" означает "место" } + if Field[i, j] = WALL then + code := 8 + else if Field[i, j] = SU then + code := 4 + else if Field[i, j] = SD then + code := 5 + else if Field[i, j] = SL then + code := 6 + else if Field[i, j] = SR then + code := 7 + else if (Field[i, j] = SPACE) and (Places[i, j] <> 0) then + begin + Form1.ImageList.GetBitmap(0, bitmap); + Form1.BackBuffer.Canvas.Draw((i - 1) * 32, (j - 1) * 32, bitmap); + code := 8 + Places[i, j] + end + else if Field[i, j] = SPACE then + code := 0 + { а пара "камень" / "место" - "камень на месте" } + else if Field[i, j] = Places[i, j] then + begin + code := 3; + { При этом увеличиваем счетчик размещенных камней. } + Inc(Positioned) + end + else if Field[i, j] > 0 then + begin + Form1.ImageList.GetBitmap(2, bitmap); + Form1.BackBuffer.Canvas.Draw((i - 1) * 32, (j - 1) * 32, bitmap); + code := 8 + Field[i, j] + end; + + Form1.ImageList.GetBitmap(code, bitmap); { Достаем картинку } + { и рисуем ее на соответствующем месте виртуального экрана. } + Form1.BackBuffer.Canvas.Draw((i - 1) * 32, (j - 1) * 32, bitmap) + end; + + bitmap.Free; + + { Копируем содержимое виртуального экрана на основной. } + ScreenRect := Rect(0, 0, 640, 384); + Form1.Screen.Canvas.CopyRect(ScreenRect, Form1.BackBuffer.Canvas, ScreenRect) +end; + +{--------------------------------------------------------------------------} + +procedure TForm1.ItemExitClick(Sender: TObject); +begin + Application.Terminate +end; + +{--------------------------------------------------------------------------} + +procedure TForm1.ItemOpenClick(Sender: TObject); +begin + if OpenDialog.Execute then + begin + LoadLevel(OpenDialog.FileName); + RedrawField + end; +end; + +{--------------------------------------------------------------------------} + +procedure TForm1.FormShow(Sender: TObject); +begin + while not OpenDialog.Execute do + ; + + LoadLevel(OpenDialog.FileName); + RedrawField +end; + +{--------------------------------------------------------------------------} + +function PositionBy(x, y: Integer; scale: Integer = 1): Integer; +begin + Result := Field[CurX + x * scale, CurY + y * scale] +end; + +procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +var + dx, dy: Integer; { Смещения Сокобана (куда идем). } + SprIdx: Integer; { Текущий номер его спрайта. } +begin + if Busy then Exit; { Если обработчик занят, выходим. } + + Busy := true; { статус = занято } + case Key of + VK_LEFT: + begin { идем влево } + dx := -1; + dy := 0; + SprIdx := SL + end; + VK_RIGHT: + begin { вправо } + dx := 1; + dy := 0; + SprIdx := SR + end; + VK_UP: + begin { вверх } + dx := 0; + dy := -1; + SprIdx := SU + end; + VK_DOWN: + begin { вниз } + dx := 0; + dy := 1; + SprIdx := SD + end; + else + { никуда не идем } + dx := 0; + dy := 0; + SprIdx := Field[CurX, CurY] + end; + + if PositionBy(dx, dy) = SPACE then { если целевая клетка пуста } + begin + Field[CurX + dx, CurY + dy] := SprIdx; { переходим в нее } + Field[CurX, CurY] := SPACE; { на старой позиции теперь ничего нет } + CurX := CurX + dx; + CurY := CurY + dy; + end + { если целевая клетка содержит камень, а клетка, следующая за ней, пуста } + else if (PositionBy(dx, dy) = BOULDER) and (PositionBy(dx, dy, 2) = SPACE) then + begin { двигаем камень: } + Field[CurX + dx, CurY + dy] := SprIdx; { новая позиция Сокобана } + Field[CurX + 2 * dx, CurY + 2 * dy] := BOULDER; { новая позиция камня } + Field[CurX, CurY] := SPACE; { на старой позиции - пусто } + CurX := CurX + dx; + CurY := CurY + dy; + end; + + RedrawField; { перерисовываем уровень } + { Если все камни размещены } + if Positioned = PlaceCount then + Application.MessageBox('Уровень пройден!', 'Sokoban', MB_ICONEXCLAMATION); + + Application.ProcessMessages; + Busy := false; { статус = свободно } +end; + +end. -- cgit v1.2.3