Program TETRIS;
uses crt,graph;
label m1,m2,e,de; {метки m1-выходт из цикла падения,e-выход из праграмы}
var pole,k : array [1..12,1..24] of integer; {матрици прорисовывания фигур}
podsk : array [1..3,1..4] of integer;
del,del2,i,j,I2,j2,p,m,Fig,Fig2,
gran,rr:integer; {параметры циклов и др переменые}
o,y,h : integer;
och : string;
key: char; {переменная содерж знач клавиши нажатой пользователем}
{---------------------иницелизация графического режима-----------------------}
Procedure grav;
var dr,regim:integer;
begin
dr:=vga;
regim:=vgahi;
initgraph(dr,regim,'a:\');
{initgraph(dr,regim,'c:\tp\bgi');}
end;
{-----------------------Звуковое сопровождение-------------------------------}
Procedure saund (hz,z:integer);
begin
sound (hz);
delay (del*z);
nosound;
end;
{-------------------------------палка 1--------------------------------------}
Procedure fpalka1;
begin
for i:=1 to 4 do k[4+i,1]:=1;
end;
{------------------------------Фигура"Т"-------------------------------------}
Procedure fT1;
begin
k[5,1]:=2;
k[6,1]:=2;
k[7,1]:=2;
k[6,2]:=2;
end;
{-----------------------------Фигура "Квадрат"-------------------------------}
Procedure fkv;
begin
k[6,1]:=5;
k[7,1]:=5;
k[6,2]:=5;
k[7,2]:=5;
end;
{-----------------------------Фигура "САПОГ1"--------------------------------}
Procedure fsap1;
begin
k[6,1]:=3;
k[7,1]:=3;
k[6,2]:=3;
k[6,3]:=3;
end;
{-----------------------------Фигура "САПОГ2"--------------------------------}
Procedure fsap2;
begin
k[6,1]:=10;
k[7,1]:=10;
k[7,2]:=10;
k[7,3]:=10;
end;
{-----------------------------Фигура "Лесенка1"------------------------------}
Procedure les1;
begin
k[5,1]:=9;
k[6,1]:=9;
k[6,2]:=9;
k[7,2]:=9;
end;
{-----------------------------Фигура "Лесенка2"------------------------------}
Procedure les2;
begin
k[6,1]:=12;
k[7,1]:=12;
k[6,2]:=12;
k[5,2]:=12;
end;
{-------------------------------выбор фигуры---------------------------------}
Procedure rfigyr1;
begin
o:=o+1;
fig:=fig2;
fig2:=random(7);
case fig of {значение цвета для фугур:}
0: fkv; {5}
1: fpalka1; {1}
2: fT1; {2}
3: fsap1; {3}
4: fsap2; {10}
5: les1; {9}
6: les2; {12}
end;
end;
{-------------------обнуление массива K(стирание фигур)----------------------}
Procedure zirk;
begin
for i:=1 to 12 do
for j:=1 to 24 do k[i,j]:=0;
end;
{-------------------падение любой фигуры на строчку вниз---------------------}
Procedure podenie;
begin
for i:=12 downto 1 do
for j:=23 downto 1 do
if k[i,j]<>0then begin
k[i,j+1]:=k[i,j];
k[i,j]:=0;
end;
end;
{---------------------------движение фигуры влево----------------------------}
Procedure levo;
begin;
for i:=2 to 12 do
for j:=1 to 24 do begin
k[i-1,j]:=k[i,j];
k[i,j]:=0;
end;
end;
{---------------------------движение фигуры вправо---------------------------}
Procedure pravo;
begin
for i:=11 downto 1 do
for j:=1 to 24 do begin
k[i+1,j]:=k[i,j];
k[i,j]:=0;
end;
end;
{-------------------------прорисовка фигур и роля----------------------------}
Procedure drpole;
begin
end;
{-----------------просмотр правилности команды-------------------------------}
Procedure test;
begin
for i:=1 to 12
do for j:=1 to 24
do begin
if k[i,j]<>0 then
begin
if ((i=1)and((key='4')or(key=#75))) or ((i=12)and((key='6')or(key=#77))) then key:='a';
if (pole[i-1,j]<>0) and ((key='4')or(key=#75)) then key:='a';
if (pole[i+1,j]<>0) and ((key='6')or(key=#77)) then key:='a';
if pole[i,j+1]<>0 then m:=1; {для выхода из цикла}
if j=24 then m:=1;
end;
end;
end;
{-------------оставление в массиве pole текущий массив k<>0------------------}
Procedure KiPOLE;
begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then pole [i,j]:=k[i,j];
end;
{-------------------------стирание заполненной строки------------------------}
Procedure delstrok;
Begin
End;
{--------------------выход если стакан заполнен доверху----------------------}
Procedure ex;
begin
for i:=1 to 12
do If pole [i,1]<>0 then begin
m:=2;
saund (80,250);
end;
end;
{------------------------------быстрое падение-------------------------------}
Procedure spod;
label m3;
var sp : integer;
begin
o:=o+5;
saund (400,20);
for sP:=1 to 24 do begin
test;
if m=1 then goto m3;
podenie;
end;
m3:
end;
{----------------------тест поворота фигур-----------------------------------}
Procedure testrot;
begin
case fig of
1: if (j=24) or (j=1) or (j=2) then rr:=1
else if (pole[i+1,j+1]<>0) or (pole[i+1,j]<>0) or (pole[i+1,j-1]<>0) or (pole[i+1,j-2]<>0) then rr:=1;
12: if (i=1) or (i=12) or (i=11) then rr:=1
else if (pole[i-1,j+2]<>0) or (pole[i,j+2]<>0) or (pole[i+1,j+2]<>0) or (pole[i+2,j+2]<>0) then rr:=1;
2 : if (j=1) or (pole[i+1,j-1]<>0) then rr:=1;
22: if (i=11)or (pole[i+2,j]<>0) then rr:=1;
23: if (j=24)or (pole[i+1,j+1]<>0) then rr:=1;
24: if (i=1) or (pole[i-1,j+1]<>0) then rr:=1;
3 : if (i=11)or (pole[i+2,j]<>0) or (pole[i+2,j+1]<>0) then rr:=1;
32: if (j=23)or (pole[i+1,j+2]<>0) or (pole[i+2,j+2]<>0) then rr:=1;
33: if (i=1) or (pole[i-1,j]<>0) or (pole[i-1,j-1]<>0) then rr:=1;
34: if (j=1) or (pole[i,j-1]<>0) or (pole[i+1,j-1]<>0) then rr:=1;
4 : if (i=1) or (pole[i-1,j+2]<>0) or (pole[i,j+2]<>0) then rr:=1;
42: if (j=2) or (pole[i,j-1]<>0) or (pole[i,j-2]<>0) then rr:=1;
43: if (i=11)or (pole[i+1,j]<>0) or (pole[i+2,j]<>0) then rr:=1;
44: if (j=23)or (pole[i+2,j+1]<>0) or (pole[i+2,j+2]<>0) then rr:=1;
5 : if (j=23)or (pole[i+2,j]<>0) or (pole[i+1,j+2]<>0) then rr:=1;
52: if (i=1) or (pole[i-1,j-1]<>0) or (pole[i,j-1]<>0) then rr:=1;
6 : if (j=24)or (pole[i,j-1]<>0) or (pole[i+1,j+1]<>0) then rr:=1;
62: if (i=11)or (pole[i+1,j]<>0) or (pole[i+2,j]<>0) then rr:=1;
end;
end;
{---------------------------------поворот фигур------------------------------}
Procedure rot;
label r;
begin
rr:=0; del:=del div 3;
case fig of
0:goto r;
{палки №1}
1: begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i,j]:=0;
k[i+2,j]:=0;
k[i+3,j]:=0;
k[i+1,j+1]:=1;
k[i+1,j]:=1;
k[i+1,j-1]:=1;
k[i+1,j-2]:=1;
fig:=12;
goto r;
end;
end;
{палка №2}
12: begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i,j+1]:=0;
k[i,j+2]:=0;
k[i,j+3]:=0;
k[i-1,j+2]:=1;
k[i,j+2]:=1;
k[i+1,j+2]:=1;
k[i+2,j+2]:=1;
fig:=1;
goto r;
end;
end;
{т №1}
2:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i+2,j]:=0;
k[i+1,j-1]:=2;
fig:=22;
goto r;
end;
end;
{T №2}
22:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i+1,j+1]:=0;
k[i+2,j]:=2;
fig:=23;
goto r;
end;
end;
{T №3}
23:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i+1,j+1]:=2;
fig:=24;
goto r;
end;
end;
{T №4}
24:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i-1,j+1]:=2;
fig:=2;
goto r;
end;
end;
{сапог №1}
3:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j+1]:=0;
k[i,j+2]:=0;
k[i+2,j]:=3;
k[i+2,j+1]:=3;
fig:=32;
goto r;
end;
end;
{сапог № 2}
32:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i+1,j]:=0;
k[i+1,j+2]:=3;
k[i+2,j+2]:=3;
fig:=33;
goto r;
end;
end;
{сапог № 3}
33:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i+1,j-2]:=0;
k[i+1,j-1]:=0;
k[i-1,j]:=3;
k[i-1,j-1]:=3;
fig:=34;
goto r;
end;
end;
{сапог № 4}
34:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i+1,j+1]:=0;
k[i+2,j+1]:=0;
k[i,j-1]:=3;
k[i+1,j-1]:=3;
fig:=3;
goto r;
end;
end;
{сапог №1}
4:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i+1,j]:=0;
k[i-1,j+2]:=10;
k[i,j+2]:=10;
fig:=42;
goto r;
end;
end;
{сапог № 2}
42:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i+2,j-1]:=0;
k[i+2,j]:=0;
k[i,j-1]:=10;
k[i,j-2]:=10;
fig:=43;
goto r;
end;
end;
{сапог № 3}
43:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j+2]:=0;
k[i+1,j+2]:=0;
k[i+1,j]:=10;
k[i+2,j]:=10;
fig:=44;
goto r;
end;
end;
{сапог # 4}
44:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j+1]:=0;
k[i,j]:=0;
k[i+2,j+1]:=10;
k[i+2,j+2]:=10;
fig:=4;
goto r;
end;
end;
{лесенка №1}
5:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i+1,j]:=0;
k[i+2,j]:=9;
k[i+1,j+2]:=9;
fig:=52;
goto r;
end;
end;
{лесенка №2}
52:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i+1,j-1]:=0;
k[i,j+1]:=0;
k[i-1,j-1]:=9;
k[i,j-1]:=9;
fig:=5;
goto r;
end;
end;
{лесенка №1}
6 :begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i+1,j-1]:=0;
k[i+2,j-1]:=0;
k[i,j-1]:=12;
k[i+1,j+1]:=12;
fig:=62;
goto r;
end;
end;
{лесенка №2}
62:begin
for i:=1 to 12 do
for j:=1 to 24 do if k[i,j]<>0 then begin
testrot;
if rr=1 then goto r;
k[i,j]:=0;
k[i+1,j+2]:=0;
k[i+1,j]:=12;
k[i+2,j]:=12;
fig:=6;
goto r;
end;
end;
end;
r:
end;
{----------------------------------Подсказка---------------------------------}
Procedure podskazka;
var x1,x2,y1,y2:integer;
begin
for i:=1 to 3 do
for j:=1 to 4 do podsk[i,j]:=0;
case Fig2 of
0: begin
podsk[1,3]:=5;
podsk[2,3]:=5;
podsk[1,4]:=5;
podsk[2,4]:=5;
end;
1: begin
podsk[2,1]:=1;
podsk[2,2]:=1;
podsk[2,3]:=1;
podsk[2,4]:=1;
end;
2: begin
podsk[1,3]:=2;
podsk[2,3]:=2;
podsk[3,3]:=2;
podsk[2,4]:=2;
end;
3: begin
podsk[2,2]:=3;
podsk[2,3]:=3;
podsk[2,4]:=3;
podsk[3,2]:=3;
end;
4: begin
podsk[2,2]:=10;
podsk[2,3]:=10;
podsk[2,4]:=10;
podsk[1,2]:=10;
end;
5: begin
podsk[1,3]:=9;
podsk[2,3]:=9;
podsk[2,4]:=9;
podsk[3,4]:=9;
end;
6: begin
podsk[1,4]:=12;
podsk[2,3]:=12;
podsk[2,4]:=12;
podsk[3,3]:=12;
end;
end;
rectangle (500,20,560,100);
for i:=1 to 3
do begin
x1:=i*20+480;
x2:=x1+20;
for j:=1 to 4
do begin
y1:=j*20;
y2:=y1+20;
rectangle(x1,y1,x2,y2);
if podsk[i,j]<>0 then begin
setfillstyle (1,podsk[i,j]);
floodfill (x1+2,y1+2,15);
end
else begin
setfillstyle (1,7);
floodfill (x1+2,y1+2,15);
end;
end;
end;
end;
{---------------------------Очки и Уровни------------------------------------}
Procedure ochki;
begin
rectangle (50,145,110,160);
bar (52,147,108,158);
setfillstyle (1,0);
floodfill (52,147,15);
str (o,och);
outtextxy (60,150,och);
rectangle (50,345,110,360);
bar (52,347,108,358);
setfillstyle (1,0);
floodfill (52,358,15);
str (y,och);
outtextxy (75,350,och);
case y of
1: gran:=1000;
2: gran:=850;
3: gran:=700;
4: gran:=650;
5: gran:=500;
6: gran:=450;
7: gran:=350;
8: gran:=250;
9: gran:=100;
10: gran:=70;
end;
end;
{++++++++++++++++++++++++++++++++++Меню+++++++++++++++++++++++++++++++++++++
+}
{---------------------------------рамка--------------------------------------}
Procedure pamka;
begin
setcolor (8); rectangle (154,84,504,404);
setcolor (7); rectangle (152,82,502,402); rectangle (153,83,503,403);
setcolor (15);rectangle (150,80,500,400); rectangle (151,81,501,401);
setfillstyle (1,7);
floodfill (156,85,15);
setcolor (8);
line (152,82,152,399);
line (152,82,499,82);
end;
{---------------------------------гвоздики-----------------------------------}
Procedure gv (x,y: integer);
begin
setcolor (0); circle (x+1,y+1,5); setfillstyle (1,0); floodfill (x,y,0);
setcolor (8); circle (x,y,5); setfillstyle (1,8); floodfill (x,y,8);
setcolor (0);
line (x-3,y-3,x+4,y+4);
line (x-3,y-4,x+4,y+3);
end;
{-------------------------------треугольник----------------------------------}
Procedure treg(y:integer);
begin
setFillstyle (1,7);
bar (189,130,211,360);
setcolor (4);
line (190,y-10,210,y);
line (190,y+10,210,y);
line (190,y-10,190,y+10);
setfillstyle (1,4);
floodfill (200,y,4);
end;
{-------------------------------- Текст -------------------------------------}
Procedure textmanu;
begin
setcolor (10);settextstyle (0,0,4); outtextxy (232,42,'TETRIS');
setcolor (2); settextstyle (0,0,4); outtextxy (230,40,'TETRIS');
setcolor (8); settextstyle (0,0,3); outtextxy (277,92,'Menu');
setcolor (9); settextstyle (0,0,2);
outtextxy (221,151,'Play');
outtextxy (221,181,'Control');
outtextxy (221,211,'Color control');
outtextxy (221,241,'Computer tuner');
outtextxy (221,301,'Help');
outtextxy (221,271,'About');
outtextxy (221,331,'Exit');
setcolor (2);
settextstyle (0,0,1);
etcolor (15);
settextstyle (0,0,3);
outtextxy (275,90,'Menu');
setcolor (1); settextstyle (0,0,2);
outtextxy (220,150,'Play');
outtextxy (220,180,'Control');
outtextxy (220,210,'Color control');
outtextxy (220,240,'Computer tuner');
outtextxy (220,300,'Help');
outtextxy (220,270,'About');
outtextxy (220,330,'Exit');
setcolor (10);settextstyle (0,0,1);
gv (160,90); gv (490,90); gv (160,390); gv (490,390);
end;
{-------}
Procedure textabout;
begin
setcolor (10);settextstyle (0,0,4); outtextxy (232,42,'TETRIS');
setcolor (2); settextstyle (0,0,4); outtextxy (230,40,'TETRIS');
setcolor (8); settextstyle (0,0,3); outtextxy (267,92,'About');
setcolor (15);settextstyle (0,0,3); outtextxy (265,90,'About');
setcolor (9); settextstyle (0,0,2);
outtextxy (271,181,'TETRIS');
outtextxy (226,211,'Version 1.0a');
outtextxy (236,241,'© 2001 by');
outtextxy (271,271,'"TUSK"');
setcolor (1);
settextstyle (0,0,2);
outtextxy (270,180,'TETRIS');
outtextxy (225,210,'Version 1.0a');
end;
{------------------------------------About-----------------------------------}
Procedure about;
var df:string;
begin
setFillstyle (1,0);
bar (150,80,505,405);
pamka;
gv (160,90);
gv (490,90);
gv (160,390);
gv (490,390);
textabout;
df:=readkey;
setFillstyle (1,0);
bar (150,80,505,405);
end;
{------------------------------------Меню------------------------------------}
Procedure Manu;
label play,man,man2;
var key2:char;
t,l,i:integer;
keyp:Integer;
begin
man:
pamka;
textmanu;
{--- курсор ---}
t:=156;l:=1;keyp:=1;
treg (t);
man2:
repeat
keyp:=1;key2:='q';
if keypressed Then begin
Key2:=readkey;
if key2=chr(13) then keyp:=0
else keyp:=1;
end;
if (t=336) and (key2=#80) then begin t:=126; l:=0; end;
if (t=156) and (key2=#72) then begin t:=366; l:=8; end;
if key2=#80 then begin t:=t+30; treg (t);l:=l+1; end;
if key2=#72 then begin t:=t-30; treg (t);L:=l-1; end;
until keyp=0;
{-------выбор в меню--}
case l of
1 : goto play;
5 : begin about; goto man;end;
7 : halt;
else goto man2;
end;
play:
CloseGraph;
grav;
end;
{*****************************************************************************
-----------------------------начало тела програмы----------------------------
****************************************************************************}
BEGIN
clrscr;
writeln ('Введите значение задержки от 0 до 30:');
readln (del2); Grav; {инецелизация всякой ерунды}
manu;
randomize;
drpole;
fig2:=random(7);
y:=1;
m1:
kipole;
ex; if m=2 then goto e; {проверка не полон ли стакан}
zirk;
delstrok;
rfigyr1; podskazka; {выбор случайной фигуры}
ochki;
for i2:=1 to 24 {чикл падения фигури до 24 строки}
do begin
del:=del2; {задержка для разных коппов 25 видов}
drpole;
for j2:=1 to gran {чикл зависания фигуры в воздухе}
do begin
key:='a';
if keypressed then key:=readkey; {чтение команды}
m:=0; test; if (m=1)and(j2=gran) then goto m1; {тест команды}
case key of
'4',#75:begin levo; drpole; end; {движение влево}
'6',#77:begin pravo; drpole; end; {движение вправо}
'8',#72:begin rot; drpole; end; {поворот фигур}
' ':begin spod; if m=1 then goto m1; end; {быстрое падение}
'5',#80:del:=0; {убыстрить падение}
'e','у',#27: halt; {выход по требованию}
end;
delay (del); {задержка для зависания фигуры}
end;
podenie;
end;
e:
readln;
END.
но там нехватает 2 процедур delstrok и drpole так вот может кто нибудь могбы написать эти процедуры?
