Помощь - Поиск - Пользователи - Календарь
Полная версия: Змейка на паскале
Форум «Всё о Паскале» > Pascal, Object Pascal > Написание игр
-QWERTY-
20.06.2006 14:05
Вот, только там есть маленькие недорабоки:
uses CRT, Graph;
type TPoint = record
              X, Y: integer;
              end;
     MAS = array[1..1000] of TPoint;
var A: MAS;
    N, C: integer;
    T1: TPoint;
    Key: Char;
procedure DRIVER;
var Gd, Gm: integer;
begin
     Gd:=Detect;
     InitGraph(Gd, Gm, '');
end;
procedure POLE;
begin
     moveto(51, 51);
     lineto(428, 51);
     lineto(428, 428);
     lineto(51, 428);
     lineto(51, 51);
end;
procedure PAINT(T: TPoint; N: integer);
begin
     case N of
     1: SetColor(White);
     2: SetColor(Black);
     3: SetColor(Red);
     end;
     Rectangle(T.X*15-15+52, T.Y*15-15+52, T.X*15+52, T.Y*15+52);
end;
procedure GAMEOVER(A: MAS; N: integer; var Key: char);
var I: integer;
begin
     if (A[N].X=0) or (A[N].X=26) or (A[N].Y=0) or (A[N].Y=26) then
             Key:='q';
     for I:=1 to N-1 do
         if (A[N].X=A[I].X) and (A[N].Y=A[I].Y) then
            Key:='q';
end;
procedure METKA(var T1: TPoint);
begin
     T1.X:=Random(25)+1; T1.Y:=Random(25)+1;
     Paint(T1, 3);
end;
procedure SNAKE(A: MAS; N: integer; Key: char; var B: MAS);
var T: TPoint;
    I, X, Y: integer;
begin
     case Key of
     'w': begin X:=0; Y:=-1; end;
     'a': begin X:=-1; Y:=0; end;
     's': begin X:=0; Y:=1; end;
     'd': begin X:=1; Y:=0; end;
     end;
     T:=A[1];
     for I:=1 to N-1 do
         A[I]:=A[I+1];
     A[N].X:=A[N].X+X; A[N].Y:=A[N].Y+Y;
     PAINT(T, 2);
     for I:=1 to N do
         PAINT(A[I], 1);
     for I:=1 to N do
         B[I]:=A[I];
end;
begin
     DRIVER;
     POLE;
     A[1].X:=1; A[1].Y:=1; A[2].X:=2; A[2].Y:=1;
     N:=2;
     C:=0;
     Key:='d';
     repeat
           if C=30 then
              begin
                   PAINT(T1, 2);
                   METKA(T1);
                   C:=0;
              end;
           inc©;
           if (T1.X=A[N].X) and (T1.Y=A[N].Y) then
              begin
                   inc(N);
                   C:=30;
                   A[N]:=T1;
              end;
           if KeyPressed then
              Key:=readkey;
           Delay(9000);
           SNAKE(A, N, Key, A);
           GAMEOVER(A, N, Key);
     until Key='q';
     OutTextXY(315, 238, 'GAME OVER');
     OutTextXY(302, 250, 'press any key');
     readkey;
end.
volvo
20.06.2006 14:08
Ну, так зачем постишь, если недоработки есть? Исправь, тогда и покажешь...
Гость
20.06.2006 22:52
ктонить пробовал то
Bokul
20.06.2006 23:35
Цитата
ктонить пробовал то

У меня только прямоугольник показывает blink.gif
Altair
21.06.2006 14:17
Гость, а ты будешь пробовать продукт, в котором по словам-же разработчика есть недоработки ?
Некачественный товар - никому не нужен, как и производитель, создавший его!
Гость
25.06.2006 20:19
Вот
uses CRT, Graph;
type TPoint = record
              X, Y: integer;
              end;
     MAS = array[1..1000] of TPoint;
var A: MAS;
    N, C: integer;
    T1: TPoint;
    Key: Char;
    S: string;
procedure DRIVER;
var Gd, Gm: integer;
begin
     Gd:=Detect;
     InitGraph(Gd, Gm, '');
end;
procedure POLE;
begin
     moveto(51, 51);
     lineto(428, 51);
     lineto(428, 428);
     lineto(51, 428);
     lineto(51, 51);
     setcolor(white);
     outtextxy(545, 50, 'Score:');
     outtextxy(545, 220, '- exit');
     outtextxy(545, 120, '- up');
     outtextxy(545, 140, '- left');
     outtextxy(545, 160, '- down');
     outtextxy(545, 180, '- right');
     setcolor(Yellow);
     outtextxy(520, 220, '''q''');
     outtextxy(520, 120, '''w''');
     outtextxy(520, 140, '''a''');
     outtextxy(520, 160, '''s''');
     outtextxy(520, 180, '''d''');
end;
procedure PAINT(T: TPoint; N: integer);
begin
     case N of
     1: SetColor(White);
     2: SetColor(Black);
     3: begin SetColor(Red); Circle(T.X*15-8+52, T.Y*15-8+52, 7); exit; end;
     4: Begin SetColor(Black); Circle(T.X*15-8+52, T.Y*15-8+52, 7); exit; end;
     end;
     Rectangle(T.X*15-15+52, T.Y*15-15+52, T.X*15+52, T.Y*15+52);
end;
procedure GAMEOVER(A: MAS; N: integer; var Key: char);
var I: integer;
begin
     if (A[N].X=0) or (A[N].X=26) or (A[N].Y=0) or (A[N].Y=26) then
             Key:='q';
     for I:=1 to N-1 do
         if (A[N].X=A[I].X) and (A[N].Y=A[I].Y) then
            Key:='q';
end;
procedure METKA(var T1: TPoint);
begin
     T1.X:=Random(25)+1; T1.Y:=Random(25)+1;
     Paint(T1, 3);
end;
procedure SNAKE(A: MAS; N: integer; Key: char; var B: MAS);
var T: TPoint;
    I, X, Y: integer;
begin
     case Key of
     'w': begin X:=0; Y:=-1; end;
     'a': begin X:=-1; Y:=0; end;
     's': begin X:=0; Y:=1; end;
     'd': begin X:=1; Y:=0; end;
     end;
     T:=A[1];
     for I:=1 to N-1 do
         A[I]:=A[I+1];
     A[N].X:=A[N].X+X; A[N].Y:=A[N].Y+Y;
     PAINT(T, 2);
     for I:=1 to N do
         PAINT(A[I], 1);
     for I:=1 to N do
         B[I]:=A[I];
end;
begin
     Randomize;
     DRIVER;
     POLE;
     A[1].X:=1; A[1].Y:=1; A[2].X:=2; A[2].Y:=1;
     N:=2;
     C:=0;
     Key:='d';
     repeat
           if C=30 then
              begin
                   PAINT(T1, 4);
                   METKA(T1);
                   C:=0;
              end;
           inc©;
           if (T1.X=A[N].X) and (T1.Y=A[N].Y) then
              begin
                   inc(N);
                   C:=30;
                   A[N]:=T1;
                   setcolor(Black);
                   outtextxy(600, 50, S);
                   str(N-2, S);
                   setcolor(Yellow);
                   outtextxy(600, 50, S);
              end;
           if KeyPressed then
              Key:=readkey;
           Delay(9000);
           SNAKE(A, N, Key, A);
           GAMEOVER(A, N, Key);
     until Key='q';
     OutTextXY(315, 238, 'GAME OVER');
     OutTextXY(302, 250, 'press any key');
     readkey;
end.
Гость
14.06.2007 23:17
uses CRT, Graph;
type TPoint = record
	      X, Y: integer;
	      end;
     MAS = array[1..1000] of TPoint;
     label 23,24;
var A: MAS;
    ag, N, C, sp, speed: integer;
    T1: TPoint;
    Key: Char;
    S: string;
procedure POLE;
begin
     moveto(51, 51);
     lineto(428, 51);
     lineto(428, 428);
     lineto(51, 428);
     lineto(51, 51);
     setcolor(white);
     outtextxy(545, 50, 'Schet:');
     outtextxy(545, 220, '- Vihod');
     outtextxy(545, 120, '- vverh');
     outtextxy(545, 140, '- vlevo');
     outtextxy(545, 160, '- vniz');
     outtextxy(545, 180, '- vpravo');
     setcolor(Yellow);
     outtextxy(520, 220, '''q''');
     outtextxy(520, 120, '''w''');
     outtextxy(520, 140, '''a''');
     outtextxy(520, 160, '''s''');
     outtextxy(520, 180, '''d''');
end;
procedure PAINT(T: TPoint; N: integer);
begin
     case N of
     1: SetColor(White);
     2: SetColor(Black);
     3: begin SetColor(Red); Circle(T.X*15-8+52, T.Y*15-8+52, 7); exit; end;
     4: Begin SetColor(Black); Circle(T.X*15-8+52, T.Y*15-8+52, 7); exit; end;
     end;
     Rectangle(T.X*15-15+52, T.Y*15-15+52, T.X*15+52, T.Y*15+52);
end;
procedure GAMEOVER(A: MAS; N: integer; var Key: char);
var I: integer;
begin
     if (A[N].X=0) or (A[N].X=26) or (A[N].Y=0) or (A[N].Y=26) then
	     Key:='q';
     for I:=1 to N-1 do
	 if (A[N].X=A[I].X) and (A[N].Y=A[I].Y) then
	    Key:='q';
end;
procedure METKA(var T1: TPoint);
begin
     T1.X:=Random(25)+1; T1.Y:=Random(25)+1;
     Paint(T1, 3);
end;
procedure SNAKE(A: MAS; N: integer; Key: char; var B: MAS);
var T: TPoint;
    I, X, Y: integer;
begin
     case Key of
     'w': begin X:=0; Y:=-1; end;
     'a': begin X:=-1; Y:=0; end;
     's': begin X:=0; Y:=1; end;
     'd': begin X:=1; Y:=0; end;
     end;
     T:=A[1];
     for I:=1 to N-1 do
	 A[I]:=A[I+1];
     A[N].X:=A[N].X+X; A[N].Y:=A[N].Y+Y;
     PAINT(T, 2);
     for I:=1 to N do
	 PAINT(A[I], 1);
     for I:=1 to N do
	 B[I]:=A[I];
end;
  procedure GrInit;
	var Graphdriver, graphmode, errorcode :integer;
    Begin GraphDriver:=detect;
    initgraph(graphdriver,graphmode,'f:\pascal\tp7\bgi\');
    errorcode:=graphresult;
    if errorcode<>grok then begin writeln('Oshibka',GraphErrorMsg(ErrorCode));
    exit;
    end;
    end;
begin
writeln('                           Dobro pozhalovat v zmeyku! ');
writeln('                    Chtobi nachat igru - nazmite lubuy knopku!');
writeln;
writeln;
writeln('Programmu razrabotal');
writeln('Student gruppi PZ-06-1');
writeln('Metelin S.Y.');
readln;
GrInit;
     Randomize;
23:  cleardevice;
     outtextxy(10, 10, 'Vvedite scorost zmeyki (1-3):');
     writeln;
     writeln;
readln(speed);
case speed of
1: sp:=9000;
2: sp:=15000;
3: sp:=18000;
else begin
 setcolor(RED);
 outtextxy(200,200,'Vvedena nepravilnaya scorost');
 setcolor(white);
 readkey;
 outtextxy(250,300,'Nazmite Enter'); cleardevice; goto 23; end;
end;
cleardevice;
     POLE;
      A[1].X:=1; A[1].Y:=1; A[2].X:=2; A[2].Y:=1;
     N:=2;
     C:=0;
     Key:='d';
     repeat
	   if C=30 then
	      begin
		   PAINT(T1, 4);
		   METKA(T1);
		   C:=0;
	      end;
	   inc©;
	   if (T1.X=A[N].X) and (T1.Y=A[N].Y) then
	      begin
		   inc(N);
		   C:=30;
		   A[N]:=T1;
		   setcolor(Black);
		   outtextxy(600, 50, S);
		   str(N-2, S);
		   setcolor(Yellow);
		   outtextxy(600, 50, S);
	      end;
	   if KeyPressed then
	      Key:=readkey;
	   Delay(sp);
	   SNAKE(A, N, Key, A);
	   GAMEOVER(A, N, Key);
     until Key='q';
     cleardevice;
     setcolor(RED);
     OutTextXY(250, 200, 'IGRA ZAVERSHENA');
     setcolor(white);
     OutTextXY(270,225,'Vas shet:');
     OutTextXY(360,225,S);
     OutTextXY(210, 260, 'Hotite sigrat zanovo? (Y/N)');
     case readkey of
     'y': goto 23;
     end;
     delay(50000);
end.


М
 Теги.. Лопарь

SKVOZNJAK
15.06.2007 15:31
Цитата(Altair @ 21.06.2006 7:17) *

Гость, а ты будешь пробовать продукт, в котором по словам-же разработчика есть недоработки ?


Есть отмаза smile.gif Практически во всех навороченных биосах есть недоработки. Достаточно залезть на сайт разработчиков материнки и попытаться выбрать. То с температурой баги, то страничный кадр EMS занят, то усб лучше не включать. Адреного пространства явно недостаточно чтобы впихнуть всё желаемое.
Но вот это inc©; явно неправильный код.
inc©;
Исходники нужно оформлять в теги кода, чтобы смайлы и прочее в нём вдруг не появились.

Такс. С самого начала ерунда. Ты пишешь "нажмите на любую кнопку". Лучше писать "клавишу", но поскольку ты используешь readln, то "энтер". После этого включается графический режим, какой writeln? С delay надо разобраться. На быстрых машинах лучше использовать новый crt или патчить имеющийся, соответственно delay(1000) станет как и положено 1 секунда. Яблоко подкрасил, а то бледное, незрелое или наоборот, гнилое smile.gif Приделай паузу.
uses new_CRT, Graph;
type TPoint = record
X, Y: integer;
end;
MAS = array[1..1000] of TPoint;
label 23,24;
var A: MAS;
aa, ag, N, C, sp, speed: integer;
T1: TPoint;
Key: Char;
S: string;

procedure POLE;
begin
moveto(51, 51);
lineto(428, 51);
lineto(428, 428);
lineto(51, 428);
lineto(51, 51);
setcolor(white);
outtextxy(545, 50, 'Schet:');
outtextxy(545, 220, '- Vihod');
outtextxy(545, 120, '- vverh');
outtextxy(545, 140, '- vlevo');
outtextxy(545, 160, '- vniz');
outtextxy(545, 180, '- vpravo');
setcolor(Yellow);
outtextxy(520, 220, '''q''');
outtextxy(520, 120, '''w''');
outtextxy(520, 140, '''a''');
outtextxy(520, 160, '''s''');
outtextxy(520, 180, '''d''');
end;

procedure PAINT(T: TPoint; N: integer);
begin
case N of
1: SetColor(White);
2: SetColor(Black);
3: begin SetColor(Red); for aa:=2 to 7 do Circle(T.X*15-8+52, T.Y*15-8+52, aa); exit; end;
4: Begin SetColor(Black); for aa:=2 to 7 do Circle(T.X*15-8+52, T.Y*15-8+52, aa); exit; end;
end;
Rectangle(T.X*15-15+52, T.Y*15-15+52, T.X*15+52, T.Y*15+52);
end;
procedure GAMEOVER(A: MAS; N: integer; var Key: char);
var I: integer;
begin
if (A[N].X=0) or (A[N].X=26) or (A[N].Y=0) or (A[N].Y=26) then
Key:='q';
for I:=1 to N-1 do
if (A[N].X=A[I].X) and (A[N].Y=A[I].Y) then
Key:='q';
end;

procedure METKA(var T1: TPoint);
begin
T1.X:=Random(25)+1; T1.Y:=Random(25)+1;
Paint(T1, 3);
end;
procedure SNAKE(A: MAS; N: integer; Key: char; var B: MAS);
var T: TPoint;
I, X, Y: integer;
begin
case Key of
'w': begin X:=0; Y:=-1; end;
'a': begin X:=-1; Y:=0; end;
's': begin X:=0; Y:=1; end;
'd': begin X:=1; Y:=0; end;
end;
T:=A[1];
for I:=1 to N-1 do
A[I]:=A[I+1];
A[N].X:=A[N].X+X; A[N].Y:=A[N].Y+Y;
PAINT(T, 2);
for I:=1 to N do
PAINT(A[I], 1);
for I:=1 to N do
B[I]:=A[I];
end;

procedure GrInit;
var Graphdriver, graphmode, errorcode :integer;
Begin GraphDriver:=detect;
initgraph(graphdriver,graphmode,'');
errorcode:=graphresult;
if errorcode<>grok then begin writeln('Oshibka',GraphErrorMsg(ErrorCode));
exit;
end;
end;
begin
writeln(' Dobro pozhalovat v zmeyku! ');
writeln(' Chtobi nachat igru - nazmite lubuy knopku!');
writeln;
writeln;
writeln('Programmu razrabotal');
writeln('Student gruppi PZ-06-1');
writeln('Metelin S.Y.');
readln;
GrInit;
Randomize;
23: cleardevice;
outtextxy(10, 10, 'Vvedite scorost zmeyki (1-3):');
readln(speed);
case speed of
1: sp:=180;
2: sp:=150;
3: sp:=90;
else begin
setcolor(RED);
outtextxy(200,200,'Vvedena nepravilnaya scorost');
setcolor(white);
readkey;
outtextxy(250,300,'Nazmite Enter'); cleardevice; goto 23;
     end;
end;
cleardevice;
POLE;
A[1].X:=1; A[1].Y:=1; A[2].X:=2; A[2].Y:=1;
N:=2;
C:=0;
Key:='d';
repeat
if C=30 then
begin
PAINT(T1, 4);
METKA(T1);
C:=0;
end;
inc©;
if (T1.X=A[N].X) and (T1.Y=A[N].Y) then
begin
inc(N);
C:=30;
A[N]:=T1;
setcolor(Black);
outtextxy(600, 50, S);
str(N-2, S);
setcolor(Yellow);
outtextxy(600, 50, S);
end;
if KeyPressed then
Key:=readkey;
Delay(sp);
SNAKE(A, N, Key, A);
GAMEOVER(A, N, Key);
until Key='q';
cleardevice;
setcolor(RED);
OutTextXY(250, 200, 'IGRA ZAVERSHENA');
setcolor(white);
OutTextXY(270,225,'Vas shet:');
OutTextXY(360,225,S);
OutTextXY(210, 260, 'Hotite sigrat zanovo? (Y/N)');
case readkey of
'y': goto 23;
end;
delay(500);
end.

Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.