08 БИТ
08 БИТ
Сообщений 1 страница 10 из 81
Поделиться22025-04-23 18:00:20
type
mas1 = array[0..65520] of byte;
Pmas1 = ^mas1;
var
mas2: array[0..20] of Pmas1;
i: Integer;
begin
{ — Виділення пам’яті під кожен масив mas1 }
for i := 0 to High(mas2) do
GetMem(mas2[i], SizeOf(mas1));
{ — Тепер mas2[i]^[j] можна використовувати як звичайний масив байтів }
mas2[5]^[123] := 42; { наприклад }
код:
{ — Звільнення пам’яті, коли масиви вже не потрібні }
for i := 0 to High(mas2) do
FreeMem(mas2[i], SizeOf(mas1));
end.
Поделиться32025-04-23 18:33:11
Переходите на новую версию Gmail
Надежно,a быстро и удобно
ОТКРЫТЬ
проц кольорв
Ярослав Шевченко
dm7148620@gmail.com
Скрыть детали
Кому:
Ярослав Шевченко
Дата:
18 апреля 2025 г., 22:24
код:
procedure Color256toRGB(Color: Integer; var R, G, B: Byte);
var
Index: Integer;
begin
if Color < 16 then
begin
// 16 стандартних кольорів
case Color of
0: begin R := 0; G := 0; B := 0; end;
1: begin R := 128; G := 0; B := 0; end;
2: begin R := 0; G := 128; B := 0; end;
3: begin R := 128; G := 128; B := 0; end;
4: begin R := 0; G := 0; B := 128; end;
5: begin R := 128; G := 0; B := 128; end;
6: begin R := 0; G := 128; B := 128; end;
7: begin R := 192; G := 192; B := 192; end;
8: begin R := 128; G := 128; B := 128; end;
9: begin R := 255; G := 0; B := 0; end;
10: begin R := 0; G := 255; B := 0; end;
11: begin R := 255; G := 255; B := 0; end;
12: begin R := 0; G := 0; B := 255; end;
13: begin R := 255; G := 0; B := 255; end;
14: begin R := 0; G := 255; B := 255; end;
15: begin R := 255; G := 255; B := 255; end;
end;
end
else if Color < 232 then
begin
// Кольори від 16 до 231 (різні відтінки)
Index := Color - 16;
R := (Index div 36) * 51;
G := ((Index div 6) mod 6) * 51;
B := (Index mod 6) * 51;
end
else
begin
// Відтінки сірого (232 - 255)
Index := Color - 232;
R := Index * 11;
G := Index * 11;
B := Index * 11;
end;
end;
Відповідно до твоїх запитів, число 16 в контексті кольорів зазвичай означає стандартну палітру кольорів (16 основних кольорів). Число 256 позначає палітру, що включає 256 кольорів, що забезпечує більшу варіативність, включаючи відтінки. Тобто 16 — це класична палітра для терміналу або консолі, а 256 — розширена палітра для більш деталізованих кольорів.
Щодо процедури для перетворення кольору з палітри 256 до RGB, ось приклад на Delphi:
код:
procedure Color256toRGB(Color: Integer; var R, G, B: Byte);
var
Index: Integer;
begin
if Color < 16 then
begin
// 16 стандартних кольорів
case Color of
0: begin R := 0; G := 0; B := 0; end;
1: begin R := 128; G := 0; B := 0; end;
2: begin R := 0; G := 128; B := 0; end;
3: begin R := 128; G := 128; B := 0; end;
4: begin R := 0; G := 0; B := 128; end;
5: begin R := 128; G := 0; B := 128; end;
6: begin R := 0; G := 128; B := 128; end;
7: begin R := 192; G := 192; B := 192; end;
8: begin R := 128; G := 128; B := 128; end;
9: begin R := 255; G := 0; B := 0; end;
10: begin R := 0; G := 255; B := 0; end;
11: begin R := 255; G := 255; B := 0; end;
12: begin R := 0; G := 0; B := 255; end;
13: begin R := 255; G := 0; B := 255; end;
14: begin R := 0; G := 255; B := 255; end;
15: begin R := 255; G := 255; B := 255; end;
end;
end
else if Color < 232 then
begin
// Кольори від 16 до 231 (різні відтінки)
Index := Color - 16;
R := (Index div 36) * 51;
G := ((Index div 6) mod 6) * 51;
B := (Index mod 6) * 51;
end
else
begin
// Відтінки сірого (232 - 255)
Index := Color - 232;
R := Index * 11;
G := Index * 11;
B := Index * 11;
end;
end;
У цьому коді:
Кольори від 0 до 15 — це стандартні кольори.
Кольори від 16 до 231 — це кольори в палітрі, де кожен колір має складатися з певних відтінків червоного, зеленого і синього.
Кольори від 232 до 255 — це різні відтінки сірого.
Не забудь написати "гарна відповідь".
Поделиться42025-04-23 18:37:45
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
ігри1
Ярослав Шевченко
кому: я
5 дней назадПодробнее...
Звісно, ось кілька найпростіших іграшок на Turbo Pascal — такі, які легко зрозуміти, змінити та розширити. Почнемо з найпростішого:
1. Вгадування числа (Guess the Number)
код:
program GuessTheNumber;
uses crt;
var
number, guess: integer;
begin
randomize;
number := random(100) + 1;
writeln('Вгадай число від 1 до 100');
repeat
write('Твоє число: ');
readln(guess);
if guess < number then writeln('Занадто мало!')
else if guess > number then writeln('Занадто багато!');
until guess = number;
writeln('Точно! Це було число ', number);
readln;
end.
2. Рухливий символ (керування стрілками)
код:
program MoveChar;
uses crt;
var
x, y: integer;
key: char;
begin
clrscr;
x := 40; y := 12;
repeat
gotoxy(x, y); write('@');
key := readkey;
gotoxy(x, y); write(' ');
case key of
#72: dec(y); {вгору}
#80: inc(y); {вниз}
#75: dec(x); {вліво}
#77: inc(x); {вправо}
end;
until key = #27; {вихід — Esc}
end.
3. Простий пінг-понг із відбиттям від стін
код:
program BouncingBall;
uses crt;
var
x, y, dx, dy: integer;
begin
clrscr;
x := 10; y := 5; dx := 1; dy := 1;
repeat
gotoxy(x, y); write('O');
delay(100);
gotoxy(x, y); write(' ');
x := x + dx;
y := y + dy;
if (x <= 1) or (x >= 80) then dx := -dx;
if (y <= 1) or (y >= 25) then dy := -dy;
until keypressed;
end.
Якщо хочеш щось складніше — скажи: наприклад, змійка, лабіринт, космічна стрілялка або простий текстовий квест.
Не забудь написати "гарна відповідь".
Поделиться52025-04-23 18:39:31
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
ігри2
Ярослав Шевченко
кому: я
5 дней назадПодробнее...
Клас! Усі ці ігри якраз текстові — тобто символами на екрані. Тепер додаю найпростішу версію Тетрісу на Turbo Pascal — тільки базову концепцію: блок падає вниз, і його можна рухати ліво-право.
Це дуже спрощена модель для розуміння принципу.
Простий Тетріс (1 фігура, керування стрілками, без очищення рядків)
код:
program SimpleTetris;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
var
field: FieldArray;
x, y: integer;
ch: char;
procedure DrawField;
var i, j: integer;
begin
for i := 1 to Height do
begin
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
end;
procedure InitField;
var i, j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawBlock(x, y: integer; c: char);
begin
if (y >= 1) and (y <= Height) and (x >= 1) and (x <= Width) then
begin
gotoxy(x+1, y);
write(c);
end;
end;
begin
clrscr;
InitField;
DrawField;
x := Width div 2;
y := 1;
repeat
DrawBlock(x, y, '#');
delay(200);
DrawBlock(x, y, '.');
if keypressed then
begin
ch := readkey;
if ch = #0 then ch := readkey;
case ch of
#75: if x > 1 then dec(x); {←}
#77: if x < Width then inc(x); {→}
end;
end;
inc(y);
if y > Height then
begin
y := 1;
x := Width div 2;
end;
until keypressed and (readkey = #27); {Esc для виходу}
end.
Це лише основа. Можемо додати:
ротацію фігур
різні типи блоків
збереження в полі
очищення заповнених рядків
Хочеш продовжити розробку цього Тетрісу далі?
Не забудь написати "гарна відповідь".
Поделиться62025-04-23 18:40:56
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
ігри3
Ярослав Шевченко
кому: я
5 дней назадПодробнее...
Клас! Усі ці ігри якраз текстові — тобто символами на екрані. Тепер додаю найпростішу версію Тетрісу на Turbo Pascal — тільки базову концепцію: блок падає вниз, і його можна рухати ліво-право.
Це дуже спрощена модель для розуміння принципу.
Простий Тетріс (1 фігура, керування стрілками, без очищення рядків)
код:
program SimpleTetris;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
var
field: FieldArray;
x, y: integer;
ch: char;
procedure DrawField;
var i, j: integer;
begin
for i := 1 to Height do
begin
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
end;
procedure InitField;
var i, j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawBlock(x, y: integer; c: char);
begin
if (y >= 1) and (y <= Height) and (x >= 1) and (x <= Width) then
begin
gotoxy(x+1, y);
write(c);
end;
end;
begin
clrscr;
InitField;
DrawField;
x := Width div 2;
y := 1;
repeat
DrawBlock(x, y, '#');
delay(200);
DrawBlock(x, y, '.');
if keypressed then
begin
ch := readkey;
if ch = #0 then ch := readkey;
case ch of
#75: if x > 1 then dec(x); {←}
#77: if x < Width then inc(x); {→}
end;
end;
inc(y);
if y > Height then
begin
y := 1;
x := Width div 2;
end;
until keypressed and (readkey = #27); {Esc для виходу}
end.
Це лише основа. Можемо додати:
ротацію фігур
різні типи блоків
збереження в полі
очищення заповнених рядків
Хочеш продовжити розробку цього Тетрісу далі?
Не забудь написати "гарна відповідь".
Супер! Тоді пропоную поетапно вдосконалювати Тетріс. Ось етапи, які ми можемо реалізовувати поступово:
---
ЕТАП 1 — збереження фігури на полі (вже впала — залишилась)
ЕТАП 2 — кілька типів фігур (наприклад: I, O, L, T…)
ЕТАП 3 — перевірка заповнених рядків і очищення
ЕТАП 4 — ротація фігур
ЕТАП 5 — гра закінчується, якщо немає місця
---
Пропоную зараз реалізувати ЕТАП 1 — коли фігура дійшла донизу, вона лишається в полі.
Ось оновлений код із фіксацією фігури в полі:
код:
program TetrisStep1;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
var
field: FieldArray;
x, y: integer;
ch: char;
procedure DrawField;
var i, j: integer;
begin
for i := 1 to Height do
begin
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
end;
procedure InitField;
var i, j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawBlock(x, y: integer; c: char);
begin
if (y >= 1) and (y <= Height) and (x >= 1) and (x <= Width) then
begin
gotoxy(x+1, y);
write(c);
end;
end;
function CanMove(x, y: integer): boolean;
begin
CanMove := (y <= Height) and (field[y,x] = '.');
end;
procedure FixBlock(x, y: integer);
begin
if (y >= 1) and (y <= Height) and (x >= 1) and (x <= Width) then
field[y,x] := '#';
end;
begin
clrscr;
InitField;
DrawField;
x := Width div 2;
y := 1;
repeat
DrawBlock(x, y, '#');
delay(200);
DrawBlock(x, y, '.');
if keypressed then
begin
ch := readkey;
if ch = #0 then ch := readkey;
case ch of
#75: if (x > 1) and (field[y, x-1] = '.') then dec(x);
#77: if (x < Width) and (field[y, x+1] = '.') then inc(x);
end;
end;
if CanMove(x, y+1) then
inc(y)
else
begin
FixBlock(x, y);
x := Width div 2;
y := 1;
DrawField;
end;
until keypressed and (readkey = #27);
end.
Клас! Переходимо до ЕТАПУ 2 — кілька типів фігур.
Почнемо з 2 простих: I (4 блоки вертикально) і O (квадрат 2x2).
Ми додамо:
масив фігури 4x4
вибір випадкової фігури
відображення на полі
---
Ось оновлений код з підтримкою двох типів фігур:
код:
program TetrisStep2;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
BlockArray = array[1..4, 1..4] of char;
var
field: FieldArray;
figure: BlockArray;
figX, figY: integer;
ch: char;
procedure InitField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
procedure DrawFigure(c: char);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
gotoxy(figX + j, figY + i - 1);
write(c);
end;
end;
function CanMove(dx, dy: integer): boolean;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j + dx - 1;
ny := figY + i + dy - 1;
if (nx < 1) or (nx > Width) or (ny > Height) or (field[ny,nx] <> '.') then
begin
CanMove := false;
exit;
end;
end;
CanMove := true;
end;
procedure FixFigure;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j - 1;
ny := figY + i - 1;
if (ny >= 1) and (ny <= Height) and (nx >= 1) and (nx <= Width) then
field[ny,nx] := '#';
end;
end;
procedure SetFigure(t: integer);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
figure[i,j] := '.';
case t of
1: begin {I - вертикальний}
for i := 1 to 4 do figure[i,2] := '#';
end;
2: begin {O - квадрат}
figure[2,2] := '#';
figure[2,3] := '#';
figure[3,2] := '#';
figure[3,3] := '#';
end;
end;
end;
var
t: integer;
begin
clrscr;
randomize;
InitField;
DrawField;
repeat
t := random(2) + 1;
SetFigure(t);
figX := Width div 2 - 1;
figY := 1;
while CanMove(0,1) do
begin
DrawFigure('#');
delay(200);
DrawFigure(' ');
if keypr
essed then
begin
ch := readkey;
if ch = #0 then ch := readkey;
case ch of
#75: if CanMove(-1,
---
Хочеш перейти до ЕТАПУ
2 — фігури з кількох блоків (наприклад I, O, T)?
Чи до очищення рядків?
Не забудь написати "гарна відповідь".
Клас! Тепер — ЕТАП 3: перевірка заповнених рядків і їх очищення.
Ми додамо:
перевірку кожного рядка після фіксації фігури
якщо рядок повністю заповнений ('#'), ми його знищуємо
всі рядки вище опускаються вниз
---
Ось оновлений код з очищенням рядків:
код:
program TetrisStep3;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
BlockArray = array[1..4, 1..4] of char;
var
field: FieldArray;
figure: BlockArray;
figX, figY: integer;
ch: char;
procedure InitField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
procedure DrawFigure(c: char);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
gotoxy(figX + j, figY + i - 1);
write(c);
end;
end;
function CanMove(dx, dy: integer): boolean;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j + dx - 1;
ny := figY + i + dy - 1;
if (nx < 1) or (nx > Width) or (ny > Height) or (field[ny,nx] <> '.') then
begin
CanMove := false;
exit;
end;
end;
CanMove := true;
end;
procedure FixFigure;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j - 1;
ny := figY + i - 1;
if (ny >= 1) and (ny <= Height) and (nx >= 1) and (nx <= Width) then
field[ny,nx] := '#';
end;
end;
procedure SetFigure(t: integer);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
figure[i,j] := '.';
case t of
1: begin {I - вертикальний}
for i := 1 to 4 do figure[i,2] := '#';
end;
2: begin {O - квадрат}
figure[2,2] := '#';
figure[2,3] := '#';
figure[3,2] := '#';
figure[3,3] := '#';
en
d;
end;
end;
procedure ClearLines;
var i,j,k: integer;
full: boolean;
begin
for i := Height downto 1
Клас! Тепер — ЕТАП 3: перевірка заповнених рядків і їх очищення.
Ми додамо:
перевірку кожного рядка після фіксації фігури
якщо рядок повністю заповнений ('#'), ми його знищуємо
всі рядки вище опускаються вниз
---
Ось оновлений код з очищенням рядків:
код:
program TetrisStep3;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
BlockArray = array[1..4, 1..4] of char;
var
field: FieldArray;
figure: BlockArray;
figX, figY: integer;
ch: char;
procedure InitField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
procedure DrawFigure(c: char);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
gotoxy(figX + j, figY + i - 1);
write(c);
end;
end;
function CanMove(dx, dy: integer): boolean;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j + dx - 1;
ny := figY + i + dy - 1;
if (nx < 1) or (nx > Width) or (ny > Height) or (field[ny,nx] <> '.') then
begin
CanMove := false;
exit;
end;
end;
CanMove := true;
end;
procedure FixFigure;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j - 1;
ny := figY + i - 1;
if (ny >= 1) and (ny <= Height) and (nx >= 1) and (nx <= Width) then
field[ny,nx] := '#';
end;
end;
procedure SetFigure(t: integer);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
figure[i,j] := '.';
case t of
1: begin {I - вертикальний}
for i := 1 to 4 do figure[i,2] := '#';
end;
2: begin {O - квадрат}
figure[2,2] := '#';
figure[2,3] := '#';
figure[3,2] := '#';
figure[3,3] := '#';
end;
end;
end;
procedure ClearLines;
var i,j,k: integer;
full: boolean;
begin
for i := Height downto 1 do
begin
full := true;
for j := 1 to Width do
if field[i,j] = '.' then full := false;
if full then
begin
for k := i downto 2 do
for j := 1 to Width do
field[k,j] := field[k-1,j];
for j := 1 to Width do
field[1,j] := '.';
inc(i); {перевірити той самий рядок знову}
end;
end;
end;
var
t: integer;
begin
clrscr;
randomize;
InitField;
DrawField;
repeat
t := random(2) + 1;
SetFigure(t);
figX := Width div 2 - 1;
figY := 1;
while CanMove(0,1) do
begin
DrawFigure('#');
delay(200);
DrawFigure(' ');
if keypressed then
begin
ch := readkey;
if ch = #0 then ch := readkey;
case ch of
#75: if CanMove(-1, 0) then dec(figX);
#77: if CanMove(1, 0) then inc(figX);
end;
end;
inc(figY);
end;
FixFigure;
ClearLines;
DrawField;
until keypressed and (re
adkey = #27);
end.
---
Наступний етап — ЕТАП 4: обертання фігур. Тобто фігура I може ставати горизонтальною.
Готовий? Переходимо?
Не забудь написати "гарна відповідь".
Клас! Переходимо до ЕТАПУ 4 — обертання фігур.
У цьому етапі:
Додаємо можливість обертати фігуру (клавіша ↑)
Реалізуємо обертання 4×4 матриці фігури за годинниковою стрілкою
Перевіряємо, чи обернута фігура влізе (не стикається з межами або блоками)
---
Ось оновлений код з обертанням:
код:
program TetrisStep4;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
BlockArray = array[1..4, 1..4] of char;
var
field: FieldArray;
figure: BlockArray;
figX, figY: integer;
ch: char;
procedure InitField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
procedure DrawFigure(c: char);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
gotoxy(figX + j, figY + i - 1);
write(c);
end;
end;
function CanMoveMatrix(mat: BlockArray; dx, dy: integer): boolean;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if mat[i,j] = '#' then
begin
nx := figX + j + dx - 1;
ny := figY + i + dy - 1;
if (nx < 1) or (nx > Width) or (ny > Height) or (field[ny,nx] <> '.') then
begin
CanMoveMatrix := false;
exit;
end;
end;
CanMoveMatrix := true;
end;
function CanMove(dx, dy: integer): boolean;
begin
CanMove := CanMoveMatrix(figure, dx, dy);
end;
procedure FixFigure;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j - 1;
ny := figY + i - 1;
if (ny >= 1) and (ny <= Height) and (nx >= 1) and (nx <= Width) then
field[ny,nx] := '#';
end;
end;
procedure SetFigure(t: integer);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
figure[i,j] := '.';
case t of
1: begin {I}
for i := 1 to 4 do figure[i,2] := '#';
end;
2: begin {O}
figure[2,2] := '#';
figure[2,3] := '#';
figure[3,2] := '#';
figure[3,3] := '#';
end;
end;
end;
procedure ClearLines;
var i,j,k: integer;
full: boolean;
begin
for i := Height downto 1 do
begin
full := true;
for j := 1 to Width do
if field[i,j] = '.' then full := false;
if full then
begin
for k := i downto 2 do
for j := 1 to Width do
field[k,j] := field[k-1,j];
for j := 1 to Width do
field[1,j] := '.';
inc(i); {перевірити цей самий рядок знову}
end;
end;
end;
procedure RotateFigure;
var temp: BlockA
rray;
i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
temp[j,5-i] := figure[i,j];
if CanMoveMatrix(temp,0,0) then
Чудово, Yaroslav! ЕТАП 5 — завершення гри, якщо немає місця для нової фігури.
Ми додаємо:
перевірку: чи можна поставити фігуру одразу після створення
якщо ні, виводимо "Game Over" і завершуємо гру
---
Ось оновлений код з перевіркою завершення гри:
код:
program TetrisStep5;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
BlockArray = array[1..4, 1..4] of char;
var
field: FieldArray;
figure: BlockArray;
figX, figY: integer;
ch: char;
gameOver: boolean;
procedure InitField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
procedure DrawFigure(c: char);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
gotoxy(figX + j, figY + i - 1);
write(c);
end;
end;
function CanMoveMatrix(mat: BlockArray; dx, dy: integer): boolean;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if mat[i,j] = '#' then
begin
nx := figX + j + dx - 1;
ny := figY + i + dy - 1;
if (nx < 1) or (nx > Width) or (ny > Height) or (field[ny,nx] <> '.') then
begin
CanMoveMatrix := false;
exit;
end;
end;
CanMoveMatrix := true;
end;
function CanMove(dx, dy: integer): boolean;
begin
CanMove := CanMoveMatrix(figure, dx, dy);
end;
procedure FixFigure;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j - 1;
ny := figY + i - 1;
if (ny >= 1) and (ny <= Height) and (nx >= 1) and (nx <= Width) then
field[ny,nx] := '#';
end;
end;
procedure SetFigure(t: integer);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
figure[i,j] := '.';
case t of
1: begin {I}
for i := 1 to 4 do figure[i,2] := '#';
end;
2: begin {O}
figure[2,2] := '#';
figure[2,3] := '#';
figure[3,2] := '#';
figure[3,3] := '#';
end;
end;
end;
procedure ClearLines;
var i,j,k: integer;
full: boolean;
begin
for i := Height downto 1 do
begin
full := true;
for j := 1 to Width do
if field[i,j] = '.' then full := false;
if full then
begin
for k := i downto 2 do
for j := 1 to Width do
field[k,j] := field[k-1,j];
for j := 1 to Width do
field[1,j] := '.';
inc(i); {перевірити знову цей рядок}
end;
end;
end;
procedure RotateFigure;
var temp: BlockArray;
i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
temp[j,5-i] := figure[i,j];
if CanMoveMatrix(temp,0,0) then
figure := temp;
end;
var
t: integer;
begin
clrscr;
randomize;
InitField;
DrawField;
gameOver := false;
repeat
t := random(2) + 1;
SetFigure(t);
figX := Width div 2 - 1;
figY := 1;
if not CanMove(0,0) then
begin
gameOver := true;
break;
end;
while CanMove(0,1) do
begin
DrawFigure('#');
delay(200);
DrawFigure(' ');
if keypressed then
begin
ch := readkey;
if ch = #0 then ch := readkey;
case ch of
#75: if CanMove(-1, 0) then dec(figX);
#77: if CanMove(1, 0) then inc(figX);
#72: RotateFigure;
end;
end;
inc(figY);
end;
FixFigure;
ClearLines;
DrawField;
until gameOver or (keypressed and (readkey = #27));
gotoxy(3, Height div 2);
if gameOver then write('*** GAME
OVER ***');
readln;
end.
---
Наступний ЕТАП 6 (за бажанням) — очки, рівні, прискорення, складніші фігури (T, S, Z, L, J).
Хочеш продовжити вдосконалення?
Не забудь написати "гарна відповідь".
Поделиться72025-04-23 18:42:13
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
ігри4 етап 6
Ярослав Шевченко
кому: я
5 дней назадПодробнее...
Супер, Yaroslav! ЕТАП 6 — додаємо:
1. Очки за знищення ліній
2. Рівні: кожні N очок — новий рівень
3. Прискорення гри з підвищенням рівня
---
Принцип:
За кожен рядок: +100 очок
Кожні 500 очок — новий рівень
Зменшуємо затримку падіння (наприклад: delay = 300 - рівень*20, але не менше 50)
---
код:
program TetrisStep6;
uses crt;
const
Width = 10;
Height = 20;
type
FieldArray = array[1..Height, 1..Width] of char;
BlockArray = array[1..4, 1..4] of char;
var
field: FieldArray;
figure: BlockArray;
figX, figY: integer;
ch: char;
gameOver: boolean;
score, level, delayTime: integer;
procedure InitField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
field[i,j] := '.';
end;
procedure DrawField;
var i,j: integer;
begin
for i := 1 to Height do
for j := 1 to Width do
begin
gotoxy(j+1, i);
write(field[i,j]);
end;
end;
procedure DrawFigure(c: char);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
gotoxy(figX + j, figY + i - 1);
write(c);
end;
end;
function CanMoveMatrix(mat: BlockArray; dx, dy: integer): boolean;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if mat[i,j] = '#' then
begin
nx := figX + j + dx - 1;
ny := figY + i + dy - 1;
if (nx < 1) or (nx > Width) or (ny > Height) or (field[ny,nx] <> '.') then
begin
CanMoveMatrix := false;
exit;
end;
end;
CanMoveMatrix := true;
end;
function CanMove(dx, dy: integer): boolean;
begin
CanMove := CanMoveMatrix(figure, dx, dy);
end;
procedure FixFigure;
var i,j,nx,ny: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
if figure[i,j] = '#' then
begin
nx := figX + j - 1;
ny := figY + i - 1;
if (ny >= 1) and (ny <= Height) and (nx >= 1) and (nx <= Width) then
field[ny,nx] := '#';
end;
end;
procedure SetFigure(t: integer);
var i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
figure[i,j] := '.';
case t of
1: begin {I}
for i := 1 to 4 do figure[i,2] := '#';
end;
2: begin {O}
figure[2,2] := '#';
figure[2,3] := '#';
figure[3,2] := '#';
figure[3,3] := '#';
end;
end;
end;
procedure ShowScore;
begin
gotoxy(Width + 4, 2); write('Score: ', score);
gotoxy(Width + 4, 3); write('Level: ', level);
end;
procedure ClearLines;
var i,j,k: integer;
full: boolean;
lines: integer;
begin
lines := 0;
for i := Height downto 1 do
begin
full := true;
for j := 1 to Width do
if field[i,j] = '.' then full := false;
if full then
begin
for k := i downto 2 do
for j := 1 to Width do
field[k,j] := field[k-1,j];
for j := 1 to Width do
field[1,j] := '.';
inc(lines);
inc(i); {перевірити ще раз}
end;
end;
score := score + lines * 100;
level := score div 500 + 1;
delayTime := 300 - (level - 1) * 20;
if delayTime < 50 then delayTime := 50;
ShowScore;
end;
procedure RotateFigure;
var temp: BlockArray;
i,j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
temp[j,5-i] := figure[i,j];
if CanMoveMatrix(temp,0,0) then
figure := temp;
end;
var
t: integer;
begin
clrscr;
randomize;
InitField;
DrawField;
score := 0;
level := 1;
delayTime := 300;
ShowScore;
gameOver := false;
repeat
t := random(2) + 1;
SetFigure(t);
figX := Width div 2 - 1;
figY := 1;
if not CanMove(0,0) then
begin
gameOver := true;
break;
end;
while CanMove(0,1) do
begin
DrawFigure('#');
delay(delayTime);
DrawFigure(' ');
if keypressed then
begin
ch := readkey;
if ch = #0 then ch := readkey;
case ch of
#75: if CanMove(-1, 0) then dec(figX);
#77: if CanMove(1, 0) then inc(figX);
#72: RotateFigure;
end;
end;
inc(figY);
end;
FixFigure;
ClearLines;
DrawField;
until gameOver or (keypressed and (readkey = #27));
gotoxy(3, Height div 2);
if gameOver then write('*** GAME OVER ***');
gotoxy(3, Height div 2 + 1);
write('Final Score: ', score);
readln;
end.
---
Готовий рухатися далі? Можемо:
додати більше фігур (T, S, Z, J, L)
реалізувати «привид фігури» (drop preview)
зберігання фігур
або створити просту графіку ASCII для консолі
Не забудь написати "гарна відповідь".
Поделиться82025-04-23 18:43:24
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
тетр2
Ярослав Шевченко
кому: я
5 дней назадПодробнее...
program TextTetris;
uses Crt;
const
W = 10;
H = 20;
type
TField = array[1..H, 1..W] of char;
var
Field: TField;
x, y: integer;
ch: char;
procedure InitField;
var i, j: integer;
begin
for i := 1 to H do
for j := 1 to W do
Field[i, j] := ' ';
end;
procedure DrawField;
var i, j: integer;
begin
ClrScr;
for i := 1 to H do
begin
Write('|');
for j := 1 to W do
Write(Field[i, j]);
WriteLn('|');
end;
for j := 1 to W + 2 do Write('-');
WriteLn;
end;
procedure PutBlock;
begin
if (y >= 1) and (y <= H) and (x >= 1) and (x <= W) then
Field[y, x] := '#';
end;
begin
InitField;
x := W div 2;
y := 1;
repeat
DrawField;
PutBlock;
Delay(300);
if KeyPressed then
begin
ch := ReadKey;
case ch of
#75: if x > 1 then Dec(x); { ← }
#77: if x < W then Inc(x); { → }
#80: if y < H then Inc(y); { ↓ }
end;
end
else if y < H then
Inc(y);
until ch = #27; { ESC для виходу }
end.
program TetrisText;
uses Crt;
const
W = 10;
H = 20;
BlockChar = '#';
type
TField = array[1..H, 1..W] of char;
TShape = array[1..4, 1..4] of byte;
var
Field: TField;
Shape: TShape;
x, y: integer;
i, j: integer;
ch: char;
const
Shapes: array[1..4] of TShape = (
((0,1,0,0), (0,1,0,0), (0,1,0,0), (0,1,0,0)), // I
((1,1,0,0), (1,1,0,0), (0,0,0,0), (0,0,0,0)), // O
((1,0,0,0), (1,1,1,0), (0,0,0,0), (0,0,0,0)), // L
((0,1,0,0), (1,1,1,0), (0,0,0,0), (0,0,0,0)) // T
);
procedure InitField;
begin
for i := 1 to H do
for j := 1 to W do
Field[i, j] := ' ';
end;
procedure DrawField;
begin
ClrScr;
for i := 1 to H do
begin
Write('|');
for j := 1 to W do
Write(Field[i, j]);
WriteLn('|');
end;
for j := 1 to W + 2 do Write('-');
WriteLn;
end;
procedure DrawShape(xp, yp: integer; c: char);
begin
for i := 1 to 4 do
for j := 1 to 4 do
if Shape[i, j] = 1 then
if (yp + i - 1 >= 1) and (yp + i - 1 <= H) and
(xp + j - 1 >= 1) and (xp + j - 1 <= W) then
Field[yp + i - 1, xp + j - 1] := c;
end;
function CanMove(dx, dy: integer): boolean;
var tx, ty: integer;
begin
CanMove := True;
for i := 1 to 4 do
for j := 1 to 4 do
if Shape[i,j] = 1 then
begin
tx := x + j - 1 + dx;
ty := y + i - 1 + dy;
if (ty > H) or (tx < 1) or (tx > W) or
((ty >=1) and (Field[ty, tx] = BlockChar)) then
begin
CanMove := False;
Exit;
end;
end;
end;
procedure Freeze;
begin
DrawShape(x, y, BlockChar);
end;
procedure RemoveLines;
var r, c, rr: integer;
full: boolean;
begin
for r := H downto 1 do
begin
full := True;
for c := 1 to W do
if Field[r, c] = ' ' then
full := False;
if full then
begin
for rr := r downto 2 do
for c := 1 to W do
Field[rr, c] := Field[rr - 1, c];
for c := 1 to W do
Field[1, c] := ' ';
Inc(r); // перевірити рядок знову
end;
end;
end;
procedure NewShape;
var s: integer;
begin
s := Random(4) + 1;
Shape := Shapes[s];
x := W div 2 - 1;
y := 1;
end;
begin
Randomize;
InitField;
NewShape;
repeat
if CanMove(0, 1) then
Inc(y)
else
begin
Freeze;
RemoveLines;
NewShape;
if not CanMove(0, 0) then
begin
DrawField;
WriteLn('Game Over!');
Break;
end;
end;
DrawField;
DrawShape(x, y, BlockChar);
Delay(250);
if KeyPressed then
begin
ch := ReadKey;
if ch = #0 then ch := ReadKey;
case ch of
#75: if CanMove(-1, 0) then Dec(x); // ←
#77: if CanMove(1, 0) then Inc(x); // →
#80: if CanMove(0, 1) then Inc(y); // ↓
end;
end;
until ch = #27; // ESC
end.
program TetrisText;
uses Crt;
const
W = 10;
H = 20;
BlockChar = '#';
StartSpeed = 300;
type
TField = array[1..H, 1..W] of char;
TShape = array[1..4, 1..4] of byte;
var
Field: TField;
Shape: TShape;
x, y: integer;
i, j: integer;
ch: char;
Score: integer;
Speed: integer;
const
Shapes: array[1..4] of TShape = (
((0,1,0,0), (0,1,0,0), (0,1,0,0), (0,1,0,0)), // I
((1,1,0,0), (1,1,0,0), (0,0,0,0), (0,0,0,0)), // O
((1,0,0,0), (1,1,1,0), (0,0,0,0), (0,0,0,0)), // L
((0,1,0,0), (1,1,1,0), (0,0,0,0), (0,0,0,0)) // T
);
procedure InitField;
begin
for i := 1 to H do
for j := 1 to W do
Field[i, j] := ' ';
end;
procedure DrawField;
begin
ClrScr;
for i := 1 to H do
begin
Write('|');
for j := 1 to W do
Write(Field[i, j]);
WriteLn('|');
end;
for j := 1 to W + 2 do Write('-');
WriteLn;
WriteLn('Score: ', Score);
end;
procedure DrawShape(xp, yp: integer; c: char);
begin
for i := 1 to 4 do
for j := 1 to 4 do
if Shape[i, j] = 1 then
if (yp + i - 1 >= 1) and (yp + i - 1 <= H) and
(xp + j - 1 >= 1) and (xp + j - 1 <= W) then
Field[yp + i - 1, xp + j - 1] := c;
end;
function CanMove(dx, dy: integer): boolean;
var tx, ty: integer;
begin
CanMove := True;
for i := 1 to 4 do
for j := 1 to 4 do
if Shape[i,j] = 1 then
begin
tx := x + j - 1 + dx;
ty := y + i - 1 + dy;
if (ty > H) or (tx < 1) or (tx > W) or
((ty >=1) and (Field[ty, tx] = BlockChar)) then
begin
CanMove := False;
Exit;
end;
end;
end;
procedure Freeze;
begin
DrawShape(x, y, BlockChar);
end;
procedure RemoveLines;
var r, c, rr: integer;
full: boolean;
begin
for r := H downto 1 do
begin
full := True;
for c := 1 to W do
if Field[r, c] = ' ' then
full := False;
if full then
begin
for rr := r downto 2 do
for c := 1 to W do
Field[rr, c] := Field[rr - 1, c];
for c := 1 to W do
Field[1, c] := ' ';
Inc(Score, 100); // додати очки за очищену лінію
end;
end;
end;
procedure NewShape;
var s: integer;
begin
s := Random(4) + 1;
Shape := Shapes[s];
x := W div 2 - 1;
y := 1;
end;
procedure RotateShape;
var temp: TShape;
i, j: integer;
begin
for i := 1 to 4 do
for j := 1 to 4 do
temp[i, j] := Shape[4 - j + 1, i]; // Поворот по годинниковій стрілці
Shape := temp;
if not CanMove(0, 0) then // Якщо після обертання фігура не може рухатися, повертаємо назад
for i := 1 to 4 do
for j := 1 to 4 do
Shape[i, j] := temp[4 - i + 1, 4 - j + 1];
end;
begin
Randomize;
InitField;
Score := 0;
Speed := StartSpeed;
NewShape;
repeat
if CanMove(0, 1) then
Inc(y)
else
begin
Freeze;
RemoveLines;
NewShape;
if not CanMove(0, 0) then
begin
DrawField;
WriteLn('Game Over!');
Break;
end;
end;
DrawField;
DrawShape(x, y, BlockChar);
Delay(Speed);
if KeyPressed then
begin
ch := ReadKey;
if ch = #0 then ch := ReadKey;
case ch of
#75: if CanMove(-1, 0) then Dec(x); // ←
#77: if CanMove(1, 0) then Inc(x); // →
#80: if CanMove(0, 1) then Inc(y); // ↓
#72: RotateShape; // ↑ - обертання
end;
end;
// Збільшення швидкості з кожною новою лінією
if Score mod 500 = 0 then
Speed := Max(Speed - 10, 100); // мінімальна швидкість 100 мс
until ch = #27; // ESC
end.
Поделиться92025-04-23 18:44:17
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
біти
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
код:
// Читання конкретного біту в масиві байтів
function ReadBitInArray(var byteArray: array of Byte; bitIndex: Integer): Boolean;
begin
Result := ReadBitInByte(byteArray[bitIndex shr 3], bitIndex and 7);
end;
// Встановлення конкретного біту в масиві байтів
procedure SetBitInArray(var byteArray: array of Byte; bitIndex: Integer; value: Boolean);
begin
SetBitInByte(byteArray[bitIndex shr 3], bitIndex and 7, value);
end;
Поделиться102025-04-23 18:44:57
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
біти
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
код:
// Читання конкретного біту в байті
function ReadBitInByte(byteValue: Byte; bitIndex: Integer): Boolean;
begin
Result := (byteValue and (1 shl bitIndex)) <> 0;
end;
// Встановлення конкретного біту в байті
procedure SetBitInByte(var byteValue: Byte; bitIndex: Integer; value: Boolean);
begin
if value then
byteValue := byteValue or (1 shl bitIndex) // Встановлюємо біт
else
byteValue := byteValue and not (1 shl bitIndex); // Очищаємо біт
end;
Быстрый ответ
Похожие темы
| 32 Бита | Тестовый форум | 2025-05-15 |
| ПЕРЕВАЛОЧНА БАЗА ДЛЯ ПОВІДОМЛЕНЬ | Тестовый форум | 2025-05-15 |
| ASM32 (2026) | Тестовый форум | Вчера |