Игра «Поросенок Петр» на Delphi 7 без VCL

Tech · 14 июн 2026 в 07:51

Реализация игры «Поросенок Петр» на Delphi 7 без использования VCL, только старые добрые функции WinAPI.

Игрок управляет красным трактором, который может перестраиваться по трём полосам,
уворачиваясь от встречных машин (синих легковых и коричневых грузовиков).

Код (Pascal):

program Game;

uses

Windows, Messages;

const

ID_TIMER = 1;

ROAD_WIDTH = 360;

SCREEN_WIDTH = 800;

SCREEN_HEIGHT = 700;

FPS = 60;

TIMER_INTERVAL = 700 div FPS;

const

BLACK = $000000;

WHITE = $FFFFFF;

GRAY = $646464;

DARK_GRAY = $3C3C3C;

GREEN = $1E641E;

YELLOW = $64FFFF;

RED = $3232DC;

BLUE = $FF6432;

LIGHT_BLUE = $FF9664;

BROWN = $13458B;

type

TCarKind = (ckCar, ckTruck);

TCar = record

Lane: Integer;

Y: Integer;

Kind: TCarKind;

end;

TRoad = record

Left: Integer;

ScrollY: Integer;

end;

TPlayer = record

Lane: Integer;

X: Integer;

Y: Integer;

MoveDelay: Integer;

end;

TCars = record

List: array of TCar;

Count: Integer;

end;

TGameplay = record

Score: Real;

HighScore: Real;

Active: Boolean;

Speed: Real;

CarTimer: Integer;

end;

TGame = record

Road: TRoad;

Player: TPlayer;

Cars: TCars;

Gameplay: TGameplay;

end;

TGraphics = record

BufferDC: HDC;

hBitmap: HBITMAP;

hOldBitmap: HBITMAP;

end;

var

Game: TGame;

Graphics: TGraphics;

// ---------------------------------------------------------------------------

// Ôóíêöèè ðèñîâàíèÿ

// ---------------------------------------------------------------------------

procedure DrawRect(hdc: HDC; x, y, w, h: Integer; color: COLORREF; filled: Boolean = True);

var

br: HBRUSH;

pen: HPEN;

begin

if filled then

br := CreateSolidBrush(color)

else

br := GetStockObject(NULL_BRUSH);

pen := CreatePen(PS_SOLID, 1, color);

SelectObject(hdc, pen);

SelectObject(hdc, br);

Rectangle(hdc, x, y, x + w, y + h);

DeleteObject(pen);

DeleteObject(br);

end;

procedure DrawLine(hdc: HDC; x1, y1, x2, y2: Integer; color: COLORREF; width: Integer = 1);

var

pen: HPEN;

oldPen: HPEN;

begin

pen := CreatePen(PS_SOLID, width, color);

oldPen := SelectObject(hdc, pen);

MoveToEx(hdc, x1, y1, nil);

LineTo(hdc, x2, y2);

SelectObject(hdc, oldPen);

DeleteObject(pen);

end;

procedure DrawCircle(hdc: HDC; x, y, radius: Integer; color: COLORREF; filled: Boolean = True);

var

br: HBRUSH;

pen: HPEN;

begin

if filled then

br := CreateSolidBrush(color)

else

br := GetStockObject(NULL_BRUSH);

pen := CreatePen(PS_SOLID, 1, color);

SelectObject(hdc, pen);

SelectObject(hdc, br);

Ellipse(hdc, x - radius, y - radius, x + radius, y + radius);

DeleteObject(pen);

DeleteObject(br);

end;

// ---------------------------------------------------------------------------

// Âñïîìîãàòåëüíûå ôóíêöèè

// ---------------------------------------------------------------------------

function IntToStr(i: Integer): string;

begin

Str(i, Result);

end;

function FloatToStr(f: Real): string;

var

s: string;

begin

Str(f:0:0, s);

Result := s;

end;

function CarWidth(Kind: TCarKind): Integer;

begin

if Kind = ckTruck then Result := 45 else Result := 30;

end;

function CarHeight(Kind: TCarKind): Integer;

begin

if Kind = ckTruck then Result := 45 else Result := 40;

end;

function GetPlayerRect: TRect;

begin

Result.Left := Game.Player.X - 15;

Result.Top := Game.Player.Y - 20;

Result.Right := Game.Player.X + 15;

Result.Bottom := Game.Player.Y + 20;

end;

function GetCarRect(const car: TCar): TRect;

var

lane_width: Integer;

car_x: Integer;

begin

lane_width := ROAD_WIDTH div 3;

car_x := Game.Road.Left + lane_width div 2 + car.Lane * lane_width;

Result.Left := car_x - CarWidth(car.Kind) div 2;

Result.Top := car.Y - CarHeight(car.Kind) div 2;

Result.Right := car_x + CarWidth(car.Kind) div 2;

Result.Bottom := car.Y + CarHeight(car.Kind) div 2;

end;

function CheckCollision(const r1, r2: TRect): Boolean;

begin

Result := not ((r1.Right <= r2.Left) or (r1.Left >= r2.Right) or

(r1.Bottom <= r2.Top) or (r1.Top >= r2.Bottom));

end;

// ---------------------------------------------------------------------------

// Èíèöèàëèçàöèÿ

// ---------------------------------------------------------------------------

procedure InitRoad(var Road: TRoad);

begin

Road.Left := (SCREEN_WIDTH - ROAD_WIDTH) div 2;

Road.ScrollY := 0;

end;

procedure InitPlayer(var Player: TPlayer);

begin

Player.Lane := 1;

Player.X := SCREEN_WIDTH div 2;

Player.Y := SCREEN_HEIGHT - 80;

Player.MoveDelay := 0;

end;

procedure InitCars(var Cars: TCars);

begin

Cars.List := nil;

Cars.Count := 0;

end;

procedure InitGameplay(var Gameplay: TGameplay);

begin

Gameplay.Score := 0;

Gameplay.HighScore := 0;

Gameplay.Active := True;

Gameplay.Speed := 4.0;

Gameplay.CarTimer := 0;

end;

procedure InitGraphics(var Graphics: TGraphics; hWnd: HWND);

var

hdcWindow: HDC;

begin

hdcWindow := GetDC(hWnd);

Graphics.hBitmap := CreateCompatibleBitmap(hdcWindow, SCREEN_WIDTH, SCREEN_HEIGHT);

Graphics.BufferDC := CreateCompatibleDC(hdcWindow);

Graphics.hOldBitmap := SelectObject(Graphics.BufferDC, Graphics.hBitmap);

ReleaseDC(hWnd, hdcWindow);

end;

// ---------------------------------------------------------------------------

// Èãðîâàÿ ëîãèêà

// ---------------------------------------------------------------------------

procedure UpdatePlayer;

var

lane_width: Integer;

target_x: Integer;

begin

with Game do

begin

if not Gameplay.Active then Exit;

if Player.MoveDelay <= 0 then

begin

if (GetAsyncKeyState(VK_LEFT) and $8000) <> 0 then

begin

if Player.Lane > 0 then Dec(Player.Lane);

Player.MoveDelay := 10;

end

else if (GetAsyncKeyState(VK_RIGHT) and $8000) <> 0 then

begin

if Player.Lane < 2 then Inc(Player.Lane);

Player.MoveDelay := 10;

end;

end

else

Dec(Player.MoveDelay);

lane_width := ROAD_WIDTH div 3;

target_x := Road.Left + lane_width div 2 + Player.Lane * lane_width;

Player.X := Player.X + Round((target_x - Player.X) * 0.2);

end;

end;

procedure SpawnCar;

var

i: Integer;

lanes_in_use: array[0..2] of Boolean;

available: array[0..2] of Integer;

avail_count: Integer;

lane: Integer;

car_kind: TCarKind;

begin

with Game do

begin

if not Gameplay.Active then Exit;

FillChar(lanes_in_use, SizeOf(lanes_in_use), 0);

for i := 0 to Cars.Count - 1 do

if Cars.List[i].Y < SCREEN_HEIGHT - 100 then

lanes_in_use[Cars.List[i].Lane] := True;

avail_count := 0;

for i := 0 to 2 do

if not lanes_in_use[i] then

begin

available[avail_count] := i;

Inc(avail_count);

end;

if avail_count > 0 then

begin

lane := available[Random(avail_count)];

if Random(2) = 0 then car_kind := ckCar else car_kind := ckTruck;

SetLength(Cars.List, Cars.Count + 1);

Cars.List[Cars.Count].Lane := lane;

Cars.List[Cars.Count].Y := -Random(200) - 50;

Cars.List[Cars.Count].Kind := car_kind;

Inc(Cars.Count);

end;

end;

end;

procedure UpdateCars;

var

i: Integer;

player_rect, car_rect: TRect;

begin

with Game do

begin

i := 0;

while i < Cars.Count do

begin

Cars.List[i].Y := Cars.List[i].Y + Round(Gameplay.Speed);

if Cars.List[i].Y - 30 > SCREEN_HEIGHT then

begin

// óäàëÿåì ìàøèíó

Cars.List[i] := Cars.List[Cars.Count - 1];

Dec(Cars.Count);

SetLength(Cars.List, Cars.Count);

Gameplay.Score := Gameplay.Score + 10;

Continue;

end;

if Gameplay.Active then

begin

player_rect := GetPlayerRect;

car_rect := GetCarRect(Cars.List[i]);

if CheckCollision(player_rect, car_rect) then

begin

Gameplay.Active := False;

if Gameplay.Score > Gameplay.HighScore then

Gameplay.HighScore := Gameplay.Score;

end;

end;

Inc(i);

end;

end;

end;

procedure UpdateGame;

begin

with Game do

begin

if not Gameplay.Active then Exit;

Gameplay.Speed := 4.0 + Gameplay.Score / 1500;

if Gameplay.Speed > 11.0 then Gameplay.Speed := 11.0;

Gameplay.Score := Gameplay.Score + 0.2;

Inc(Gameplay.CarTimer);

if Gameplay.CarTimer > 30 + Round(30 - Gameplay.Score / 100) then

begin

if Gameplay.CarTimer > 60 - Round(Gameplay.Score / 100) then

begin

Gameplay.CarTimer := 0;

SpawnCar;

end;

end;

UpdateCars;

UpdatePlayer;

Road.ScrollY := (Road.ScrollY + Round(Gameplay.Speed)) mod 40;

end;

end;

procedure RestartGame;

begin

InitRoad(Game.Road);

InitPlayer(Game.Player);

InitCars(Game.Cars);

InitGameplay(Game.Gameplay);

end;

// ---------------------------------------------------------------------------

// Îòðèñîâêà

// ---------------------------------------------------------------------------

procedure DrawRoad(hdc: HDC);

var

i: Integer;

lane_width: Integer;

line_x: Integer;

y: Integer;

y_pos: Integer;

begin

DrawRect(hdc, Game.Road.Left, 0, ROAD_WIDTH, SCREEN_HEIGHT, GRAY, True);

DrawLine(hdc, Game.Road.Left, 0, Game.Road.Left, SCREEN_HEIGHT, YELLOW, 4);

DrawLine(hdc, Game.Road.Left + ROAD_WIDTH, 0, Game.Road.Left + ROAD_WIDTH, SCREEN_HEIGHT, YELLOW, 4);

lane_width := ROAD_WIDTH div 3;

for i := 1 to 2 do

begin

line_x := Game.Road.Left + i * lane_width;

y := -40;

while y < SCREEN_HEIGHT + 40 do

begin

y_pos := y + Game.Road.ScrollY;

if (y_pos >= 0) and (y_pos <= SCREEN_HEIGHT) then

DrawLine(hdc, line_x, y_pos, line_x, y_pos + 20, WHITE, 3);

Inc(y, 40);

end;

end;

end;

procedure DrawCar(hdc: HDC; const car: TCar);

var

x: Integer;

lane_width: Integer;

begin

lane_width := ROAD_WIDTH div 3;

x := Game.Road.Left + lane_width div 2 + car.Lane * lane_width;

if car.Kind = ckTruck then

begin

DrawRect(hdc, x - 22, car.Y - 22, 45, 45, BROWN, True);

DrawRect(hdc, x - 15, car.Y - 28, 30, 10, DARK_GRAY, True);

end

else

begin

DrawRect(hdc, x - 15, car.Y - 20, 30, 40, BLUE, True);

DrawRect(hdc, x - 12, car.Y - 25, 24, 15, DARK_GRAY, True);

end;

DrawRect(hdc, x - 17, car.Y - 12, 6, 12, BLACK, True);

DrawRect(hdc, x + 11, car.Y - 12, 6, 12, BLACK, True);

DrawRect(hdc, x - 17, car.Y + 8, 6, 12, BLACK, True);

DrawRect(hdc, x + 11, car.Y + 8, 6, 12, BLACK, True);

end;

procedure DrawPlayerCar(hdc: HDC);

var

x: Integer;

begin

x := Game.Player.X;

DrawRect(hdc, x - 15, Game.Player.Y - 20, 30, 40, RED, True);

DrawRect(hdc, x - 12, Game.Player.Y - 25, 24, 15, RED, True);

DrawRect(hdc, x - 8, Game.Player.Y - 22, 6, 8, BLACK, True);

DrawRect(hdc, x + 2, Game.Player.Y - 22, 6, 8, BLACK, True);

DrawCircle(hdc, x - 14, Game.Player.Y - 10, 4, YELLOW, True);

DrawCircle(hdc, x + 14, Game.Player.Y - 10, 4, YELLOW, True);

DrawRect(hdc, x - 16, Game.Player.Y - 12, 6, 12, BLACK, True);

DrawRect(hdc, x + 10, Game.Player.Y - 12, 6, 12, BLACK, True);

DrawRect(hdc, x - 16, Game.Player.Y + 8, 6, 12, BLACK, True);

DrawRect(hdc, x + 10, Game.Player.Y + 8, 6, 12, BLACK, True);

end;

procedure DrawUI(hdc: HDC);

var

i: Integer;

color: COLORREF;

textBuf: string;

oldBkMode: Integer;

begin

oldBkMode := SetBkMode(hdc, TRANSPARENT);

textBuf := 'Ñ×¨Ò: ' + FloatToStr(Int(Game.Gameplay.Score));

TextOut(hdc, 10, 10, PChar(textBuf), Length(textBuf));

textBuf := 'ÐÅÊÎÐÄ: ' + FloatToStr(Int(Game.Gameplay.HighScore));

TextOut(hdc, 10, 50, PChar(textBuf), Length(textBuf));

textBuf := 'ÑÊÎÐÎÑÒÜ: ' + FloatToStr(Round(Game.Gameplay.Speed * 25));

TextOut(hdc, 10, 90, PChar(textBuf), Length(textBuf));

for i := 0 to 2 do

begin

if i = Game.Player.Lane then color := BLUE else color := DARK_GRAY;

DrawRect(hdc, SCREEN_WIDTH - 100 + i * 25, 20, 20, 40, color, True);

DrawRect(hdc, SCREEN_WIDTH - 100 + i * 25, 20, 20, 40, BLACK, False);

end;

if not Game.Gameplay.Active then

begin

DrawRect(hdc, 0, 0, SCREEN_WIDTH, SCREEN_HEIGHT, BLACK, True);

SetBkMode(hdc, TRANSPARENT);

SetTextColor(hdc, RED);

textBuf := 'GAME OVER';

TextOut(hdc, SCREEN_WIDTH div 2 - 100, SCREEN_HEIGHT div 2 - 60, PChar(textBuf), Length(textBuf));

SetTextColor(hdc, WHITE);

textBuf := 'Ñ÷¸ò: ' + FloatToStr(Int(Game.Gameplay.Score));

TextOut(hdc, SCREEN_WIDTH div 2 - 70, SCREEN_HEIGHT div 2, PChar(textBuf), Length(textBuf));

SetTextColor(hdc, YELLOW);

textBuf := 'Ðåêîðä: ' + FloatToStr(Int(Game.Gameplay.HighScore));

TextOut(hdc, SCREEN_WIDTH div 2 - 80, SCREEN_HEIGHT div 2 + 40, PChar(textBuf), Length(textBuf));

SetTextColor(hdc, WHITE);

textBuf := 'Íàæìè R äëÿ ðåñòàðòà';

TextOut(hdc, SCREEN_WIDTH div 2 - 120, SCREEN_HEIGHT div 2 + 100, PChar(textBuf), Length(textBuf));

end;

SetBkMode(hdc, oldBkMode);

end;

procedure Render(hdc: HDC);

var

i: Integer;

begin

DrawRect(hdc, 0, 0, SCREEN_WIDTH, SCREEN_HEIGHT, GREEN, True);

DrawRoad(hdc);

for i := 0 to Game.Cars.Count - 1 do

DrawCar(hdc, Game.Cars.List[i]);

DrawPlayerCar(hdc);

DrawUI(hdc);

end;

// ---------------------------------------------------------------------------

// Îêîííàÿ ïðîöåäóðà

// ---------------------------------------------------------------------------

function MainWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;

var

ps: TPaintStruct;

hdcPaint: HDC;

begin

case Msg of

WM_CREATE:

begin

Randomize;

InitRoad(Game.Road);

InitPlayer(Game.Player);

InitCars(Game.Cars);

InitGameplay(Game.Gameplay);

InitGraphics(Graphics, hWnd);

SetTimer(hWnd, ID_TIMER, TIMER_INTERVAL, nil);

end;

WM_TIMER:

begin

if wParam = ID_TIMER then

begin

UpdateGame;

InvalidateRect(hWnd, nil, False);

end;

end;

WM_PAINT:

begin

hdcPaint := BeginPaint(hWnd, ps);

Render(Graphics.BufferDC);

BitBlt(hdcPaint, 0, 0, SCREEN_WIDTH, SCREEN_HEIGHT, Graphics.BufferDC, 0, 0, SRCCOPY);

EndPaint(hWnd, ps);

end;

WM_KEYDOWN:

begin

if wParam = VK_ESCAPE then

PostQuitMessage(0);

if wParam = Ord('R') then

RestartGame;

end;

WM_DESTROY:

begin

KillTimer(hWnd, ID_TIMER);

with Graphics do

begin

SelectObject(BufferDC, hOldBitmap);

DeleteDC(BufferDC);

DeleteObject(hBitmap);

end;

PostQuitMessage(0);

end;

else

Result := DefWindowProc(hWnd, Msg, wParam, lParam);

Exit;

end;

Result := 0;

end;

// ---------------------------------------------------------------------------

// Òî÷êà âõîäà

// ---------------------------------------------------------------------------

var

wc: TWndClass;

msg: TMsg;

begin

FillChar(wc, SizeOf(wc), 0);

wc.style := CS_HREDRAW or CS_VREDRAW;

wc.lpfnWndProc := @MainWndProc;

wc.hInstance := HInstance;

wc.hbrBackground := GetStockObject(BLACK_BRUSH);

wc.lpszClassName := 'GameClass';

RegisterClass(wc);

CreateWindow('GameClass', 'Game',

WS_OVERLAPPEDWINDOW or WS_VISIBLE,

200, 30, SCREEN_WIDTH, SCREEN_HEIGHT,

0, 0, HInstance, nil);

while GetMessage(msg, 0, 0, 0) do

begin

TranslateMessage(msg);

DispatchMessage(msg);

end;

end.

Игра + исходники.

TrashGen · 10 июн 2026 в 22:12

>>Скорость игры постепенно растёт.

Командир, мне надо в кусты срочно!

Tech · 11 июн 2026 в 01:30

TrashGen, кстати будет и вторая часть игры.

После того как поросенок Пётр успешно эмигрировал из России, он вдруг осознаёт, что мир вокруг - всего лишь симуляция.

Как и Нео, Пётр после приема таблеток узнаёт что он Избранный. В новой стране оружие легализовано. Свинья без ружья - не свинья, поэтому теперь наш герой отстреливается от агентов Матрицы (красные враги), которые пытаются его «вернуть в систему».

Для запуска игры на python: pip install pygame. Управление WASD как в кс.

--- Сообщение объединено, 11 июн 2026 в 01:30 ---

Сделал индикаторы здоровья. matrix_v2.

TrashGen · 11 июн 2026 в 11:28

Здраствуйте. Я, TrashGen. Хотел бы чтобы вы сделали игру, 2Д-экшон суть такова... Пользователь может играть поросёнком Петром, собакой Марусей и Волком. И если пользователь играет поросёнком то поросёнок в тракторе, столбики дистанционные набигают граница России и волчата. Можно довить пограничников... И поросёнку раз тракторные то сделать так что там вокруг сраный трактор... А движок можно поставить так что вдали граница полоской, когда подходиш она преобразовываются в 3-хметровый забор. Можно морфировать в самолёт и т.п. управление WASD как в кс. И оружие легализовано тоже, и норкотеки тоже легалка. Можно шмыгать и т.п. Если играть за собаку Марусю то надо жрать конфеты и пить чай с поросёнком (имя я придумал) и его трактором, агентами Матрцы, и ходит на чай к комуто из этих (стул, крышка от кастрюли…). Ну а если за Волка… то значит со всеми удобствами или в кусты надо срочно, пользователь сам себе командир может делать что сам захочет прикажет своим военам дзена с ним самим написать такую игру и пойдет напишет за джва года.
PS: Так же чтобы в игре могли не только нажраться таблеток и узнать, что он Избранный но и лишиться очков миграции и если пользователь не уйдёт в ондеграонд то его депортируют, так же "вернуться в систему" но пользователь может не продолжить играть а просто закрыть игру, или достать или купить ружьё, если выстрелить из него в ногу тоже либо умреш либо будеш ползать либо на коляске котаться, или самое хорошее… купить ружьё. Скорость игры постепенно растёт.…

Tech · 12 июн 2026 в 00:10

TrashGen, вы описали четвертую(или пятую) ондеграондную версию. Мы еще только третюю выкатили.

После перестрелки Пётр был укушен загадочным существом и обратился… в свинью-вампира(как в сумерках)!

Теперь он не просто стреляет - он пьёт кровь врагов (вампиризм), уклоняется от пуль (вампирская ловкость)
и наносит смертельные критические удары (укус вампира). За каждого убитого агента Пётр получает опыт.

Есть выбор уровня сложности (жирнее враги, больше опыта).

Tech · 13 июн 2026 в 07:12

Первая версия игры (ускользающий свин) с красным трактором на языке с.

Войти или зарегистрироваться

Игра «Поросенок Петр» на Delphi 7 без VCL

Tech Member

Вложения:

Game_v1.rar

TrashGen ТрещГен

Tech Member

Вложения:

matrix_v1.rar

matrix_v2.rar

TrashGen ТрещГен

Tech Member

Вложения:

matrix_v3.rar

Tech Member

Вложения:

Game_v1_c.rar

Войти или зарегистрироваться

Игра «Поросенок Петр» на Delphi 7 без VCL

Tech Member

Вложения:

Game_v1.rar

TrashGen ТрещГен

Tech Member

Вложения:

matrix_v1.rar

matrix_v2.rar

TrashGen ТрещГен

Tech Member

Вложения:

matrix_v3.rar

Tech Member

Вложения:

Game_v1_c.rar

Быстрый поиск