08 БИТ
08 БИТ
Сообщений 1 страница 20 из 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;
Поделиться112025-04-23 18:45:27
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
ансіаск
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
function AnsiToPseudoAscii(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
192..223: Result := Result + Chr(65 + (c - 192) mod 32); { А-Я → A-Z }
224..255: Result := Result + Chr(97 + (c - 224) mod 32); { а-я → a-z }
168, 184, 175, 191: Result := Result + Chr(105); { І і Ї ї → i }
165, 181: Result := Result + Chr(101); { Є є → e }
170, 186: Result := Result + Chr(103); { Ґ ґ → g }
else
Result := Result + Chr(c); { залишити як є }
end;
end;
end;
function PseudoAsciiToAnsi(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
65..90: Result := Result + Chr(192 + (c - 65)); { A-Z → А-Я }
97..122: Result := Result + Chr(224 + (c - 97)); { a-z → а-я }
105: Result := Result + Chr(184); { i → і (мала) }
101: Result := Result + Chr(181); { e → є (мала) }
103: Result := Result + Chr(186); { g → ґ (мала) }
else
Result := Result + Chr(c); { без змін }
end;
end;
end;
Поделиться122025-04-23 18:46:00
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
відправ ШІ
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
function AnsiToPseudoAscii(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
192..223: Result := Result + Chr(65 + (c - 192) mod 32); { À-ß > A-Z }
224..255: Result := Result + Chr(97 + (c - 224) mod 32); { à-ÿ > a-z }
168, 184, 175, 191: Result := Result + Chr(105); { І і ¯ ¿ > i }
165, 181: Result := Result + Chr(101); { Є є > e }
170, 186: Result := Result + Chr(103); { Ґ ґ > g }
else
Result := Result + Chr(c); { çàëèøèòè ÿê є }
end;
end;
end;
function PseudoAsciiToAnsi(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
65..90: Result := Result + Chr(192 + (c - 65)); { A-Z > À-ß }
97..122: Result := Result + Chr(224 + (c - 97)); { a-z > à-ÿ }
// 105: Result := Result + Chr(184); { i > і (ìàëà) }
// 101: Result := Result + Chr(181); { e > є (ìàëà) }
// 103: Result := Result + Chr(186); { g > ґ (ìàëà) }
else
Result := Result + Chr(c); { áåç çìіí }
end;
end;
end;
Твої функціі це біс знає що!
function AnsiToPseudoAscii(const s: string): string;
в дельфі 7 в консольному режимі працює невірно
а
function PseudoAsciiToAnsi(const s: string): string;
взагалі не компілюються
бо строки
105: Result := Result + Chr(184); { i > і (ìàëà) }
101: Result := Result + Chr(181); { e > є (ìàëà) }
103: Result := Result + Chr(186); { g > ґ (ìàëà) }
для case c of це дублікати
Поделиться132025-04-23 18:46:36
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
(без темы)
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
function AnsiToPseudoAscii(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
192..223: Result := Result + Chr(65 + (c - 192)); // А-Я → A-Z
224..255: Result := Result + Chr(97 + (c - 224)); // а-я → a-z
168: Result := Result + Chr(105); // І → i
184: Result := Result + Chr(105); // і → i
175: Result := Result + Chr(73); // Ї → I
191: Result := Result + Chr(105); // ї → i
165: Result := Result + Chr(69); // Є → E
181: Result := Result + Chr(101); // є → e
170: Result := Result + Chr(71); // Ґ → G
186: Result := Result + Chr(103); // ґ → g
else
Result := Result + Chr(c);
end;
end;
end;
function PseudoAsciiToAnsi(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
65..90: Result := Result + Chr(192 + (c - 65)); // A-Z → А-Я
97..122: Result := Result + Chr(224 + (c - 97)); // a-z → а-я
else case c of
105: Result := Result + Chr(184); // i → і
69: Result := Result + Chr(165); // E → Є
101: Result := Result + Chr(181); // e → є
71: Result := Result + Chr(170); // G → Ґ
103: Result := Result + Chr(186); // g → ґ
73: Result := Result + Chr(175); // I → Ї
else
Result := Result + Chr(c);
end;
end;
end;
end;
Поделиться142025-04-23 18:47:14
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
ансі
Ярослав Шевченко
function AnsiToPseudoAscii(const s: string): string; var i: Integer; c: Byte; begin Result := ''; for i := 1 to Length(s) do begin c := Ord(s[i]); ...
Ярослав Шевченко
ось що я у себе знайшов два файли Tabl_ANSI_0-255.txt Tabl_ASC_0-255.txt а ти можеш функції написати відповідно їм сб, 19 апр. 2025 г. в 14:50, Яро...
Ярослав Шевченко
ну ось дивись що мені на ось таку программу в дельфі7 виводить на екран по цьому ти зможе зробити функції переводу Анси в аск2 program p1; {$APPTYP...
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
function AnsiToPseudoAscii(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
// Кирилиця велика
$C0..$DF: Result := Result + Chr(c - $C0 + Ord('A'));
// Кирилиця мала
$E0..$FF: Result := Result + Chr(c - $E0 + Ord('a'));
// Специфічні українські
$A8, $B8: Result := Result + 'i'; // І, і
$AF: Result := Result + 'I'; // Ї
$BF: Result := Result + 'i'; // ї
$A5: Result := Result + 'E'; // Є
$B5: Result := Result + 'e'; // є
$AA: Result := Result + 'G'; // Ґ
$BA: Result := Result + 'g'; // ґ
else
Result := Result + s[i]; // Інші без змін
end;
end;
end;
суббота, 19 апреля 2025 г. пользователь Ярослав Шевченко <dm7148620@gmail.com> написал:
Поделиться152025-04-23 18:47:45
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
ансі15:40
Ярослав Шевченко
function AnsiToPseudoAscii(const s: string): string; var i: Integer; c: Byte; begin Result := ''; for i := 1 to Length(s) do begin c := Ord(s[i]); ...
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
{*}Function AnsiToAscChar(ch:char):char;{преобразование символа из Ansi в Asc}
var c:Cardinal;
begin c:=ord(ch); case c of
192..239:begin c:=c-64;end; 240..255:begin c:=c-16;end;
166:c:=124;{¦} 168:c:=240;{Ё} 184:c:=241;{ё} 170:c:=242;{Є}186:c:=243;{є}
178:{І}c:=246;{і}179:c:=247 ;
175:c:=244;{Ї}191:c:=245;{ї}
end; AnsiToAscChar:=chr(c);end; exports AnsiToAscChar;
{*}Function AnsiToAscString(s:string):String; var LengthS,c:Cardinal;
begin LengthS:=Length(S); If LengthS>0 then
begin For c:=1 to LengthS do s[c]:= AnsiToAscChar(s[c]); AnsiToAscString:=s; end; end;
сб, 19 апр. 2025 г. в 15:45, Ярослав Шевченко <dm7148620@gmail.com>:
Поделиться162025-04-23 18:50:04
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
моя фінкція від ші
Ярослав Шевченко
{*}Function AscToAnsiChar(ch: char): char; {перетворення символа з псевдо-ASCII в ANSI} var c: Cardinal; begin c := Ord(ch); case c of 128..175: c ...
Ярослав Шевченко
Ось в цьому модулі, процедури і функції (абстракції як ти називаєш) якого в майбутньому будутьв case of емулятору. Це тільки частина команд які пра...
Ярослав Шевченко
От дивись такий момент: Кожна команда буде мати різну адресацію до пам*яті хочу зробити ось так case PC of ... 1: Mov(Adr1Byte,Adr1Byte); {для одно...
Ярослав Шевченко
пн, 21 апр. 2025 г. в 08:05, Ярослав Шевченко <dm7148620@gmail.com>:
Ярослав Шевченко
кому: я
2 дня назадПодробнее...
const
ADDR_1BYTE = 0;
ADDR_2BYTE = 1;
ADDR_4BYTE = 2;
ADDR_INVALID = 3;
function GetAddrMode(InfoByte: Byte): Byte;
begin
Result := (InfoByte and $C0) shr 6;
end;
procedure DecodeAddress(var PC: LongInt; Memory: array of Byte; out Addr: LongWord);
var
Mode: Byte;
begin
Mode := GetAddrMode(Memory[PC]);
Inc(PC);
case Mode of
ADDR_1BYTE: begin
Addr := Memory[PC];
Inc(PC, 1);
end;
ADDR_2BYTE: begin
Addr := Memory[PC] or (Memory[PC + 1] shl 8);
Inc(PC, 2);
end;
ADDR_4BYTE: begin
Addr := Memory[PC] or (Memory[PC + 1] shl 8) or (Memory[PC + 2] shl 16) or (Memory[PC + 3] shl 24);
Inc(PC, 4);
end;
else
raise Exception.Create('Invalid addressing mode');
end;
end;
Поделиться172025-04-23 18:53:54
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
моя фінкція від ші
Ярослав Шевченко
кому: я
4 дня назадПодробнее...
{*}Function AscToAnsiChar(ch: char): char; {перетворення символа з псевдо-ASCII в ANSI}
var c: Cardinal;
begin
c := Ord(ch);
case c of
128..175: c := c + 64; // назад з діапазону 128–175
224..239: c := c + 16; // назад з 224–239
124: c := 166; // |
240: c := 168; // Ё
241: c := 184; // ё
242: c := 170; // Є
243: c := 186; // є
244: c := 175; // Ї
245: c := 191; // ї
246: c := 178; // І
247: c := 179; // і
end;
AscToAnsiChar := Chr(c);
end;
{*}Function AscToAnsiString(s: string): string;
var
LengthS, c: Cardinal;
begin
LengthS := Length(s);
if LengthS > 0 then
begin
for c := 1 to LengthS do
s[c] := AscToAnsiChar(s[c]);
AscToAnsiString := s;
end
else
AscToAnsiString := '';
end;
суббота, 19 апреля 2025 г. пользователь Ярослав Шевченко <dm7148620@gmail.com> написал:
{*}Function AnsiToAscChar(ch:char):char;{преобразование символа из Ansi в Asc}
var c:Cardinal;
begin c:=ord(ch); case c of
192..239:begin c:=c-64;end; 240..255:begin c:=c-16;end;
166:c:=124;{¦} 168:c:=240;{Ё} 184:c:=241;{ё} 170:c:=242;{Є}186:c:=243;{є}
178:{І}c:=246;{і}179:c:=247 ;
175:c:=244;{Ї}191:c:=245;{ї}
end; AnsiToAscChar:=chr(c);end; exports AnsiToAscChar;
{*}Function AnsiToAscString(s:string):String; var LengthS,c:Cardinal;
begin LengthS:=Length(S); If LengthS>0 then
begin For c:=1 to LengthS do s[c]:= AnsiToAscChar(s[c]); AnsiToAscString:=s; end; end;
сб, 19 апр. 2025 г. в 15:45, Ярослав Шевченко <dm7148620@gmail.com>:
function AnsiToPseudoAscii(const s: string): string;
var
i: Integer;
c: Byte;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := Ord(s[i]);
case c of
// Кирилиця велика
$C0..$DF: Result := Result + Chr(c - $C0 + Ord('A'));
// Кирилиця мала
$E0..$FF: Result := Result + Chr(c - $E0 + Ord('a'));
// Специфічні українські
$A8, $B8: Result := Result + 'i'; // І, і
$AF: Result := Result + 'I'; // Ї
$BF: Result := Result + 'i'; // ї
$A5: Result := Result + 'E'; // Є
$B5: Result := Result + 'e'; // є
$AA: Result := Result + 'G'; // Ґ
$BA: Result := Result + 'g'; // ґ
else
Result := Result + s[i]; // Інші без змін
end;
end;
end;
Ярослав Шевченко
кому: я
3 дня назадПодробнее...
Ось в цьому модулі, процедури і функції (абстракції як ти називаєш) якого в майбутньому
будутьв case of емулятору.
Це тільки частина команд які працюють з байтами. Ті ж самі команди будуть для ворда
та кардиналом, (можливо й для інт64 теж). поки вони без case of, в режимі тестування.
Пам*ять Емулятора виглядає так:
RAM:array[0..(SizeRAMBytes-1)]of Byte;
RAMw:array[0..((SizeRAMBytes div 2)-1)]of word absolute RAM;
RAMc:array[0..((SizeRAMBytes div 4)-1)]of Cardinal absolute RAM;
тобто абсолютована типами "одна на одну".
Ще поки не все є в interface.
Інше думаю не суть важливо.
Проаналізуй та скажи, чого тут явно, ну от зовсім явно не вистачає.
І загальний опис зроби.
Заздалегідь. дякую! 
unit uByte;
interface
uses uTypes;
Procedure VarByte(Var Bt:TByteEM);overload;
Procedure VarByte(Var Bt:TByteEM; Value:byte);overload;
procedure R(var Rg1:TByteEM;var Rg2:TByteEM);overload;
{+}
procedure P(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;
procedure P(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;
implementation
uses uLabel,Dialogs;
Procedure VarByte_(Var Bt:TByteEM);
begin
BeginAdrFreeByte;{налуштування першої вільної позиції для Byte }
SetBitArray(CountBeginAdrFreeByte,True);{зарезервована пам*ять, що розмічена}
Bt.LabelDataEM.LabelEM.Marked:=True;{Була розмічена LABELA, LABELP1,LABELP2 і т.д. , True - ТАК}
Bt.LabelDataEM.LabelEM.AddrOfMark:=CountBeginAdrFreeByte;// адреса початкова якщо маркована, тобто Marked=True}
end;
Procedure VarByte(Var Bt:TByteEM);overload;
begin
If Bt.LabelDataEM.LabelEM.Marked=False {не була розмічена} then
Begin InitByte(Bt);VarByte_(Bt);
Bt.Value:=RAM[Bt.LabelDataEM.LabelEM.AddrOfMark];
end else {ShowMessage('Повторна розмітка в VarByte');}end;
Procedure VarByte(Var Bt:TByteEM; Value:byte);overload;begin
If Bt.LabelDataEM.LabelEM.Marked=False {не була розмічена} then
Begin InitByte(Bt);VarByte_(Bt);
RAM[Bt.LabelDataEM.LabelEM.AddrOfMark]:=Value;Bt.Value:=Value;
end else {ShowMessage('Повторна розмітка в VarByte');}end;
procedure Used(var Rg1:TByteEM);overload;begin Rg1.LabelDataEM.LabelEM.Used:=True;end;{ставить мітку що використовується}
procedure Synhro(var Rg1:TByteEM);overload;begin Rg1.Value:=RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark];end;{синхронізує з РАМ}
procedure UsedAndSynhro(var Rg1:TByteEM);overload;begin Rg1.LabelDataEM.LabelEM.Used:=True;Rg1.Value:=RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark];end;
{=}
procedure R(var Rg1:TByteEM;var Rg2:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark];
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
procedure R(var Rg1:TByteEM;Value:byte);overload;begin VarByte(Rg1);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=Value;UsedAndSynhro(Rg1);end;
{Rg1:=RAM[Rg2]}
procedure Rmem(var Rg1:TByteEM;var Rg2:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=RAM[RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]];
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{RAM[Rg1]:=Rg2]}
procedure memR(var Rg1:TByteEM;var Rg2:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]]:=RAM[RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]];
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{+}
procedure P(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);VarByte(Rg3);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]+RAM[Rg3.LabelDataEM.LabelEM.AddrOfMark]);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);UsedAndSynhro(Rg3);end;
procedure P(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]+Value);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{-}
procedure M(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);VarByte(Rg3);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]-RAM[Rg3.LabelDataEM.LabelEM.AddrOfMark]);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);UsedAndSynhro(Rg3);end;
procedure M(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]-Value);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{AND}
procedure AND_(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);VarByte(Rg3);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]AND RAM[Rg3.LabelDataEM.LabelEM.AddrOfMark]);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);UsedAndSynhro(Rg3);end;
procedure AND_(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]AND Value);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{XOR}
procedure XOR_(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);VarByte(Rg3);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]XOR RAM[Rg3.LabelDataEM.LabelEM.AddrOfMark]);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);UsedAndSynhro(Rg3);end;
procedure XOR_(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]XOR Value);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{OR}
procedure OR_(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);VarByte(Rg3);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]OR RAM[Rg3.LabelDataEM.LabelEM.AddrOfMark]);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);UsedAndSynhro(Rg3);end;
procedure OR_(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]OR Value);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
procedure not_(var Rg1:TByteEM); Begin
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(not(RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]));
UsedAndSynhro(Rg1);
end;
{shl}
procedure shl_(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);VarByte(Rg3);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]shl RAM[Rg3.LabelDataEM.LabelEM.AddrOfMark]);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);UsedAndSynhro(Rg3);end;
procedure shl_(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]shl Value);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{shr}
procedure shr_(var Rg1:TByteEM;var Rg2:TByteEM;var Rg3:TByteEM);overload;begin VarByte(Rg1);VarByte(Rg2);VarByte(Rg3);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]shr RAM[Rg3.LabelDataEM.LabelEM.AddrOfMark]);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);UsedAndSynhro(Rg3);end;
procedure shr_(var Rg1:TByteEM;var Rg2:TByteEM;Value:byte);overload;begin VarByte(Rg1);VarByte(Rg2);
RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]shr Value);
UsedAndSynhro(Rg1);UsedAndSynhro(Rg2);end;
{CMP}Procedure Cmp(var Rg1:TByteEM;var Rg2:TByteEM);overload; begin Used(Rg1);
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] = RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]
then RAM[adrPZ]:=1 else RAM[adrPZ]:=0;{Z - признак нулевого результата: 1-нулевой результат,0-ненулевой результат. }
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] < RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]
then RAM[adrPS]:=1 else RAM[adrPS]:=0;end;{S - знак результата: 1-результат отрицательный,0-результат положительный. Фактически это содержимое старшего разряда результата.}
{CMPZ}Procedure CmpZ(var Rg1:TByteEM;var Rg2:TByteEM);overload;begin Used(Rg1);
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] = RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]
then RAM[adrPZ]:=1 else RAM[adrPZ]:=0;end;{Z - признак нулевого результата: 1-нулевой результат,0-ненулевой результат. }
{CMPS}Procedure CmpS(var Rg1:TByteEM;var Rg2:TByteEM);overload;begin Used(Rg1);
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] < RAM[Rg2.LabelDataEM.LabelEM.AddrOfMark]
then RAM[adrPS]:=1 else RAM[adrPS]:=0;end;{S - знак результата: 1-результат отрицательный,0-результат положительный. Фактически это содержимое старшего разряда результата.}
{CMP}Procedure Cmp(var Rg1:TByteEM;Value:byte);overload;begin Used(Rg1);
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] = Value then RAM[adrPZ]:=1 else RAM[adrPZ]:=0;{Z - признак нулевого результата: 1-нулевой результат,0-ненулевой результат. }
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] < Value then RAM[adrPS]:=1 else RAM[adrPS]:=0;end;{S - знак результата: 1-результат отрицательный,0-результат положительный. Фактически это содержимое старшего разряда результата.}
{CMPZ}Procedure CmpZ(var Rg1:TByteEM;Value:byte);overload;begin Used(Rg1);
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] = Value then RAM[adrPZ]:=1 else RAM[adrPZ]:=0;end;{Z - признак нулевого результата: 1-нулевой результат,0-ненулевой результат. }
{CMPS}Procedure CmpS(var Rg1:TByteEM;Value:byte);overload;begin Used(Rg1);
if RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark] < Value then RAM[adrPS]:=1 else RAM[adrPS]:=0;end;{S - знак результата: 1-результат отрицательный,0-результат положительный. Фактически это содержимое старшего разряда результата.}
Function GotoUn0:Boolean;begin if RAM[adrPZ] = 1 then begin Result:=true end else Result:=false;{P}end;
Function GotoUnNot0:Boolean;begin if RAM[adrPZ] = 0 then begin Result:=true end else Result:=false;{P}end;
Function GotoUnM:Boolean;begin if RAM[adrPS] = 1 then begin Result:=true end else Result:=false;{P}end;
Function GotoUnP:Boolean;begin if RAM[adrPS] = 0 then begin Result:=true end else Result:=false;{P}end;
Function CallUn0:Boolean;begin if RAM[adrPZ] = 1 then begin Result:=true end else Result:=false;{P}end;
Function CallUnNot0:Boolean;begin if RAM[adrPZ] = 0 then begin Result:=true end else Result:=false;{P}end;
Function CallUnM:Boolean;begin if RAM[adrPS] = 1 then begin Result:=true end else Result:=false;{P}end;
Function CallUnP:Boolean;begin if RAM[adrPS] = 0 then begin Result:=true end else Result:=false;{P}end;
Function RetUn0:Boolean;begin if RAM[adrPZ] = 1 then begin Result:=true end else Result:=false;{P}end;
Function RetUnNot0:Boolean;begin if RAM[adrPZ] = 0 then begin Result:=true end else Result:=false;{P}end;
Function RetUnM:Boolean;begin if RAM[adrPS] = 1 then begin Result:=true end else Result:=false;{P}end;
Function RetUnP:Boolean;begin if RAM[adrPS] = 0 then begin Result:=true end else Result:=false;{P}end;
//RAMc:array[0..((SizeRAMBytes div 4)-1)]of Cardinal;
{Push}Procedure Push(var Rg1:TByteEM);overload;begin RAMc[adrSP]:=RAMc[adrSP]-1; RAMc[RAMc[adrSP]]:=RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark];end;
{Push}Procedure Push(Value:byte);overload;begin RAMc[adrSP]:=RAMc[adrSP]-1; RAMc[RAMc[adrSP]]:=Value;end;
{Pop}Procedure Pop(var Rg1:TByteEM);overload;begin RAM[Rg1.LabelDataEM.LabelEM.AddrOfMark]:=(RAMc[adrSP] and $FF);RAMc[adrSP]:=RAMc[adrSP]+1; end;
//procedure goto_(Adr1:Byte);begin MyRAM[adrRgPC]:=Adr1; end;
end.
сб, 19 апр. 2025 г. в 16:25, Ярослав Шевченко <dm7148620@gmail.com>:
Ярослав Шевченко
кому: я
2 дня назадПодробнее...
От дивись такий момент:
Кожна команда буде мати різну адресацію до пам*яті
хочу зробити ось так
case PC of ...
1: Mov(Adr1Byte,Adr1Byte); {для однобайтиних адресів 0..255}
2: case (PC+1) of
1:Mov(Adr1Word,Adr1Word); {для двубайтиних адресів 0..65535}
2:Mov(Adr1Byte3,AdrByte3); {для трибайтних адресів 0..16777215}
3:Mov(Adr1DWord,AdrDWord); {для чотирьохбайтних адресів 0..4294967296}
end; {case of}
....
end; {case of}
Чи є сенс так робити ? Чим меньше адресація тим швидше буде виклик.
Може які адресації викинути ? наприклад 1байт та 3 байти ?
вс, 20 апр. 2025 г. в 22:43, Ярослав Шевченко <dm7148620@gmail.com>:
Ярослав Шевченко
кому: я
2 дня назадПодробнее...
пн, 21 апр. 2025 г. в 08:05, Ярослав Шевченко <dm7148620@gmail.com>:
!.txt
Ярослав Шевченко
кому: я
2 дня назадПодробнее...
const
ADDR_1BYTE = 0;
ADDR_2BYTE = 1;
ADDR_4BYTE = 2;
ADDR_INVALID = 3;
function GetAddrMode(InfoByte: Byte): Byte;
begin
Result := (InfoByte and $C0) shr 6;
end;
procedure DecodeAddress(var PC: LongInt; Memory: array of Byte; out Addr: LongWord);
var
Mode: Byte;
begin
Mode := GetAddrMode(Memory[PC]);
Inc(PC);
case Mode of
ADDR_1BYTE: begin
Addr := Memory[PC];
Inc(PC, 1);
end;
ADDR_2BYTE: begin
Addr := Memory[PC] or (Memory[PC + 1] shl 8);
Inc(PC, 2);
end;
ADDR_4BYTE: begin
Addr := Memory[PC] or (Memory[PC + 1] shl 8) or (Memory[PC + 2] shl 16) or (Memory[PC + 3] shl 24);
Inc(PC, 4);
end;
else
raise Exception.Create('Invalid addressing mode');
end;
end;
Поделиться182025-04-23 18:54:29
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
(без темы)
Ярослав Шевченко
кому: я
20 часов назадПодробнее...
uses CRT;
begin
ClrScr;
TextColor(White);
GotoXY(1,1); Write(#218); for i := 2 to 78 do Write(#196); Write(#191);
for i := 2 to 24 do begin
GotoXY(1,i); Write(#179);
GotoXY(80,i); Write(#179);
end;
GotoXY(1,25); Write(#192); for i := 2 to 78 do Write(#196); Write(#217);
end.
Поделиться192025-04-23 18:56:25
Переходите на новую версию Gmail
Надежно, быстро и удобно
ОТКРЫТЬ
(без темы)
Ярослав Шевченко
кому: я
19 часов назадПодробнее...
uses CRT;
var
x: Integer;
begin
ClrScr;
x := 1;
while not KeyPressed do
begin
GotoXY(x, 10);
Write('*');
Delay(100);
GotoXY(x, 10);
Write(' ');
Inc(x);
if x > 80 then x := 1;
end;
end.
uses CRT;
var
i: Integer;
begin
ClrScr;
for i := 1 to 20 do
begin
TextColor(Random(15)+1);
GotoXY(10, 10);
Write('Hello from console!');
Delay(100);
end;
end.
uses CRT;
var
x: Integer;
ch: Char;
begin
ClrScr;
x := 40;
repeat
GotoXY(x, 12);
Write('^');
ch := ReadKey;
GotoXY(x, 12);
Write(' ');
case ch of
#75: Dec(x); // ←
#77: Inc(x); // →
end;
until ch = #27; // ESC для виходу
end.
uses CRT;
var
x, y: Integer;
begin
ClrScr;
for y := 1 to 25 do
for x := 1 to 80 do
begin
GotoXY(x, y);
Write(Char(Random(94) + 33)); // символи від ! до ~
Delay(1);
end;
end.
uses CRT;
var
i: Integer;
begin
ClrScr;
Randomize;
for i := 1 to 100 do
begin
GotoXY(Random(80)+1, Random(25)+1);
TextColor(Random(15)+1);
Write(IntToHex(Random(256), 2));
Delay(50);
end;
end.
Ярослав Шевченко
кому: я
5 часов назадПодробнее...
вт, 22 апр. 2025 г. в 23:30, Ярослав Шевченко <dm7148620@gmail.com>:
!.txt
Поделиться202025-04-24 08:07:07
О, старий добрий **консольний режим у Delphi 7** — то майже як DOS, але в костюмі з Windows NT. Ось список основних функцій і можливостей, які ти можеш використати:
---
### **1. Вивід тексту**
- `Write()` / `Writeln()` — класика, як у Turbo Pascal.
- Можна писати українською, якщо кодова сторінка дозволяє (про це нижче).
---
### **2. Введення**
- `Read()` / `Readln()` — для читання з клавіатури.
- Також можна опитувати натискання клавіш через `ReadKey` (через `crt` або WinAPI).
---
### **3. Керування кольорами (через WinAPI)**
Можна змінювати кольори тексту та фону в консолі:
код:
```pascal
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE), FOREGROUND_GREEN or BACKGROUND_BLUE);
```
---
### **4. Керування курсором**
- `SetConsoleCursorPosition()` — переміщення курсора по екрану.
- `GetConsoleCursorInfo()` / `SetConsoleCursorInfo()` — зміна вигляду курсора.
---
### **5. Очищення екрану**
- Прямої `ClrScr` немає (як у TP), але можна зробити вручну через WinAPI — залити весь буфер пробілами.
---
### **6. Обробка клавіш (без Enter)**
- `ReadConsoleInput()` або `GetAsyncKeyState()` — для ловлі клавіш.
- Можна зробити повноцінну систему типу меню чи навіть клавіатурну панель.
---
### **7. Робота з українськими літерами**
- Встановити кодову сторінку:
код:
```pascal
SetConsoleOutputCP(866); // або 1251 — що треба
SetConsoleCP(866);
```
- А потім спокійно писати `"Привіт, світе!"`
---
### **8. Робота з псевдографікою**
- Використовуються символи ASCII (від 176 до 219, наприклад).
- Можна будувати рамки, віконця, меню — усе як у доброму Borland'і.
---
### **9. Робота з мишею**
- Через WinAPI (так, можна!), опитування `ReadConsoleInput` на події миші.
- Можна ловити клацання, положення і навіть коліщатко.
---
### **10. Динамічне оновлення екрана (типу real-time)**
- Через `GotoXY()`-подібну поведінку і перерисовку елементів.
- Підходить для створення інтерфейсів, навіть псевдо-анімацій.
---
Якщо хочеш, я можу накидати тобі **готові процедури** типу `GotoXY`, `TextColor`, `DrawBox`, `WaitKey`, `MouseClick` — свій такий "CRT-лайт" модуль під Windows-консоль.
Не забудь написати "дяка"
Быстрый ответ
Похожие темы
| 32 Бита | Тестовый форум | 2025-05-15 |
| ПЕРЕВАЛОЧНА БАЗА ДЛЯ ПОВІДОМЛЕНЬ | Тестовый форум | 2025-05-15 |