program Serpiente2;
(*******************************************
* Por Victor Barbero Romero - Oct. 2.001 *
* [email protected] o @telefonica.net *
* *
*******************************************) {v2.0e}
uses crt, Graph;
const
DLY = 2;
{Cambiar este valor para hacer el juego m s lento.}
type
Puntuaci = record
name : string[15];
punt : integer;
end;
var
MaxPtosPar, PtosPar, PtosTot : integer;
PosX, PosY, BolaX, BolaY, IncrmX, IncrmY : shortint;
Lab, c, NumArray, Rtraso : shortint;
datmem, mejora, basta, Sonido, definal : boolean;
ColaX, ColaY : array[1..40] of shortint;
Laberinto : array[1..1850] of boolean;
marca : array[1..6] of Puntuaci;
P : file of Puntuaci;
TipoMov : char;
procedure IniciaVideo;
var
Driver, Modo : integer;
begin
Driver := VGA; Modo := VGAHi;
InitGraph(Driver,Modo,'.BGI');
end;
procedure AbreVentana(PX, PY, Anch, Alto : integer; Titulo : string);
var
contaX, differ, alter, tlitb : integer;
tapavent : array[1..12] of integer;
begin
alter := PX + Anch - (Anch div 5);
tlitb := alter + 20;
differ := PX - PY;
tapavent[1] := PX; tapavent[2] := PY;
tapavent[3] := PX; tapavent[4] := PY+Alto;
tapavent[5] := PX+Anch; tapavent[6] := PY+Alto;
tapavent[7] := PX+Anch; tapavent[8] := PY+(Anch div 5);
tapavent[9] := alter; tapavent[10] := PY;
tapavent[11] := PX; tapavent[12] := PY;
setcolor(0); setfillstyle(1,0);
fillpoly(6,tapavent);
setcolor(7);
line(PX-1, PY, alter, PY);
line(PX-1, PY-1, alter, PY-1);
for contaX := PX to PX+Anch do
begin
if contaX-differ < PY+Alto+1 then
begin putpixel(PX, contaX-differ, 7);
putpixel(PX-1, contaX-differ, 7); end;
if contaX-differ < PY+Alto+1 then
begin putpixel(alter, contaX-differ, 7);
putpixel(alter+1, contaX-differ, 7); end;
if alter < PX+Anch then alter := alter + 1;
putpixel(contaX, PY+Alto, 7);
putpixel(contaX-1, PY+Alto+1, 7);
if contaX < tlitb then putpixel(contaX, PY+20, 7);
Delay(4*DLY);
end;
putpixel(PX+Anch+1, PY+Alto+1, 7);
putpixel(PX+Anch, PY+Alto+1, 7);
setfillstyle(9,8);
floodfill(PX+(Anch div 2), PY+3, 7);
setfillstyle(10,8); floodfill(PX+(Anch div 2), PY+25, 7);
setcolor(15);
outtextxy(PX+12, PY+7, Titulo);
end;
procedure CreaFichero;
begin
{$I-} rewrite(P); {$I+}
for c := 1 to 6 do begin
marca[c].name := '- - -';
marca[c].punt := 0;
seek(P,c); write(P,marca[c]);
end;
end;
procedure ManejaFichero;
var
report : integer;
begin
assign(P,'srp2pnt.fps');
{$I-} reset(P); {$I+}
report := IOResult;
if report <> 0 then begin CreaFichero; end else begin
for c := 1 to 6 do begin
seek(P,c); read(P, marca[c]);
end; end; close(P);
datmem := true;
end;
procedure GrabaPunts;
var
reprt : integer;
begin
assign(P,'srp2pnt.fps');
{$I-} reset(P); {$I+}
reprt := IOResult;
if reprt <> 0 then begin CreaFichero; end else begin
for c := 1 to 6 do begin
seek(P,c); write(P, marca[c]);
end; end;
close(P);
end;
procedure MuestraPunts;
var
puntos : string[5];
begin
AbreVentana(150,140,300,250,'Mejores puntuaciones');
if datmem = false then ManejaFichero;
setcolor(7);
outtextxy(175,185,'PUNTOS');
outtextxy(300,185,'NOMBRE');
line(160,198, 420,198); line(236,180, 236,380);
setfillstyle(1,0); setcolor(0);
for c := 1 to 6 do begin
bar(165,175+(30*c), 225,190+(30*c));
bar(250,175+(30*c), 410,190+(30*c));
str(marca[c].punt, puntos);
setcolor(11); outtextxy(175,180+(30*c), puntos);
setcolor(9); outtextxy(260,180+(30*c), marca[c].name);
end;
readkey;
end;
procedure OrdenaPunts; {Utiliza el Algoritmo Bubble Short}
var
d : shortint;
puntcambio : integer;
namecambio : string[15];
begin
for c:= 1 to 6 do
begin
for d := c+1 to 6 do
begin
if marca[d].punt > marca[c].punt then
begin
puntcambio := marca[c].punt;
marca[c].punt := marca[d].punt;
marca[d].punt := puntcambio;
namecambio := marca[c].name;
marca[c].name := marca[d].name;
marca[d].name := namecambio;
end;
end;
end;
end;
procedure CompruebaMejora;
var
Nombre : string[15];
begin
if datmem = false then begin ManejaFichero; end;
for c:= 1 to 6 do begin
if PtosTot > marca[c].punt then mejora := true;
end;
if mejora then begin
AbreVentana(140,150,250,110,'Enhorabuena!');
setcolor(7);
outtextxy(159,193,'Ha superado un record!');
if Sonido then begin
Sound(293); Delay(193*DLY); NoSound; Delay(27*DLY);
Sound(293); Delay(110*DLY); NoSound; Sound(293); Delay(110*DLY);
Sound(440); Delay(330*DLY); Sound(293); Delay(110*DLY);
Sound(440); Delay(440*DLY); NoSound; end;
outtextxy(160,208,'Introduzca su nombre:');
setfillstyle(1,0); setcolor(0);
bar(160,223, 320,237); textcolor(9);
gotoxy(22,15); readln(Nombre);
marca[6].punt := PtosTot; marca[6].name := Nombre;
OrdenaPunts; GrabaPunts;
end;
MuestraPunts;
end;
procedure CamSonido;
var SonSim : string[1];
begin
SonSim := #14;
if Sonido then begin
setcolor(0); outtextxy(585,5,SonSim); Sonido := false; end
else begin
setcolor(2); outtextxy(585,5,SonSim); Sonido := true; end;
end;
procedure FinJuego;
begin
cleardevice;
AbreVentana(175,130,275,150,'FIN');
setcolor(14); outtextxy(235,185,'S E R P I E N T E');
setcolor(7); outtextxy(192,240,'Victor Barbero - Octubre 2.001');
Delay(2000*DLY);
basta := true; definal := true;
end;
procedure CambiaNivel;
var
Nivel : shortint;
c : char; nvl : string[1];
procedure PintaCuad(num,tipo : shortint);
begin
if tipo = 1 then setfillstyle(1,9);
if tipo = 0 then setfillstyle(4,9);
str(num,nvl); bar(210+(30*num),210, 230+(30*num),230);
if tipo = 1 then begin setcolor(11);
outtextxy(215+(30*num), 220, nvl); end;
end;
procedure TeclaDerecha;
begin
if Nivel < 5 then
begin
PintaCuad(Nivel+1,1);
Nivel := Nivel + 1;
end; c := 'A';
end;
procedure TeclaIzquierda;
begin
if Nivel > 1 then
begin
PintaCuad(Nivel,0);
Nivel := Nivel - 1;
end; c := 'A';
end;
begin
AbreVentana(195,150,240,110,'Nivel'); setcolor(7);
outtextxy(240,190,'Mayor dificultad'); outtextxy(375,190,#26);
outtextxy(260,240,#27); outtextxy(350,240,#26);
setcolor(1); rectangle(239,209, 261,231); rectangle(238,208, 262,232);
rectangle(269,209, 291,231); rectangle(268,208, 292,232);
rectangle(299,209, 321,231); rectangle(298,208, 322,232);
rectangle(329,209, 351,231); rectangle(328,208, 352,232);
rectangle(359,209, 381,231); rectangle(358,208, 382,232);
PintaCuad(1,1); PintaCuad(2,1); PintaCuad(3,1);
PintaCuad(4,0); PintaCuad(5,0); Nivel := 3;
repeat
if Keypressed then c := readkey;
case c of
#75 : TeclaIzquierda;
#77 : TeclaDerecha;
end;
until c=#13;
case Nivel of
1 : begin MaxPtosPar := 9+Lab; Rtraso := 100; end;
2 : begin MaxPtosPar := 14+Lab; Rtraso := 85; end;
3 : begin MaxPtosPar := 19+Lab; Rtraso := 75; end;
4 : begin MaxPtosPar := 24+Lab; Rtraso := 65; end;
5 : begin MaxPtosPar := 39+Lab; Rtraso := 53; end;
end;
setfillstyle(1,0); bar(568,4, 578,13);
setcolor(15); str(Nivel,nvl); outtextxy(569,5,nvl);
end;
procedure PintaLabs;
var
x, y : shortint;
begin
setfillstyle(11,6);
for x := 1 to 50 do
begin
for y := 1 to 37 do
begin
if Laberinto[((y-1)*50)+x] = true then begin
setcolor(12);
rectangle(8+(x*12), 6+(y*12), 20+(x*12), 18+(y*12));
setcolor(6);
rectangle(9+(x*12), 7+(y*12), 19+(x*12), 17+(y*12));
floodfill(14+(x*12), 12+(y*12), 6);
end;
end;
end;
end;
procedure EligeLaberinto;
var cn : char;
procedure BorraLabAnter;
var P : integer;
begin
for P := 1 to 1850 do
begin
Laberinto[P] := false;
end;
end;
procedure Lab2;
var P : integer;
begin
for P := 601 to 626 do begin Laberinto[P] := true; end;
for P := 1224 to 1250 do begin Laberinto[P] := true; end;
for P := 438 to 450 do begin Laberinto[P] := true; end;
for P := 1451 to 1463 do begin Laberinto[P] := true; end;
end;
procedure Lab3;
var P : integer;
begin
P := 260;
while P < 1610 do begin
P := P + 50;
Laberinto[P] := true;
Laberinto[P+31] := true;
end;
for P := 901 to 911 do begin Laberinto[P] := true; end;
for P := 990 to 1000 do begin Laberinto[P] := true; end;
end;
procedure Lab4;
var P : integer;
begin
P := 20;
while P < 756 do begin
case P of
265 :; 216 :; 167 :;
else Laberinto[P] := true; end;
P := P + 49;
end; Laberinto[19] := true; Laberinto[18] := true;
Laberinto[751] := true; Laberinto[754] := true;
Laberinto[752] := true; Laberinto[753] := true;
P := 1683;
while P > 1028 do begin
Laberinto[P] := true;
P := P - 49;
end; Laberinto[68] := true;
Laberinto[1046] := true; Laberinto[1050] := true;
Laberinto[1047] := true; Laberinto[1048] := true;
Laberinto[1049] := true;
P := 525;
while P < 1000 do begin
Laberinto[P] := true;
Laberinto[P+245] := true;
P := P + 51;
end;
for P := 1501 to 1513 do begin Laberinto[P] := true; end;
end;
procedure TAbajo;
begin
if Lab < 4 then begin
setcolor(11); setfillstyle(1,11);
bar(225,135+(20*(Lab+1)), 230,140+(20*(Lab+1)));
bar(383,135+(20*(Lab+1)), 388,140+(20*(Lab+1)));
cn := 'A'; Lab := Lab + 1; end;
end;
procedure TArriba; begin
if Lab > 1 then begin
setcolor(0); setfillstyle(1,0);
bar(225,135+(20*Lab), 230,140+(20*Lab));
bar(383,135+(20*Lab), 388,140+(20*Lab));
cn := 'A'; Lab := Lab - 1; end;
end;
begin
AbreVentana(215,120,190,114,'Laberinto');
setcolor(9);
line(222,149, 232,149); line(221,149, 221,166);
line(222,166, 232,166); line(391,149 ,381,149);
line(392,149, 392,166); line(381,166, 391,166);
line(222,169, 232,169); line(221,169, 221,186);
line(222,186, 232,186); line(391,169 ,381,169);
line(392,169, 392,186); line(381,186, 391,186);
line(222,189, 232,189); line(221,189, 221,206);
line(222,206, 232,206); line(391,189 ,381,189);
line(392,189, 392,206); line(381,206, 391,206);
line(222,209, 232,209); line(221,209, 221,226);
line(222,226, 232,226); line(391,209 ,381,209);
line(392,209, 392,226); line(381,226, 391,226);
setfillstyle(1,0); setcolor(7); Lab := 1;
bar(223,150, 390,165); outtextxy(260,155,'Sin laberinto');
bar(223,170, 390,185); outtextxy(260,175,'Laberinto 1');
bar(223,190, 390,205); outtextxy(260,195,'Laberinto 2');
bar(223,210, 390,225); outtextxy(260,215,'Laberinto 3');
outtextxy(395,165,#24); outtextxy(395,204,#25);
setcolor(11); setfillstyle(1,11);
bar(225,155, 230,160); bar(383,155, 388,160);
repeat
if Keypressed then cn := readkey;
case cn of
#72 : TArriba;
#80 : TAbajo;
end;
until cn=#13;
BorraLabAnter;
case Lab of 2 : Lab2; 3 : Lab3; 4 : Lab4; end;
end;
procedure BorraMenu;
begin
setfillstyle(1,0); floodfill(320, 240, 12);
setfillstyle(1,10);
bar(14+(BolaX*12)-2, 12+(BolaY*12)-2, 14+(BolaX*12)+2, 12+(BolaY*12)+2);
if definal = false then PintaLabs;
setcolor(14);
end;
procedure Presentacion;
begin
cleardevice;
AbreVentana(130,100,380,190,'Bienvenido!');
setcolor(14); outtextxy(180,170,'S E R P I E N T E');
setcolor(7); outtextxy(379,170,'v2.0');
outtextxy(180,220,'Presione ESC durante el juego');
outtextxy(235,240,'para entrar en el men£');
outtextxy(155,268,'Pulse cualquier tecla para continuar');
readkey;
end;
procedure Menu;
var
c : char;
begin
AbreVentana(180,125,250,180,'MENU');
setcolor(7);
outtextxy(200,180, '1.- Cambiar el nivel.');
case Sonido of
true : outtextxy(200,200, '2.- Desactivar sonido.');
false : outtextxy(200,200, '2.- Activar sonido.');
end;
outtextxy(200,220, '3.- Volver al juego.');
outtextxy(200,240, '4.- Salir del juego.');
outtextxy(200,260, '5.- Ver las puntuaciones.');
repeat
if Keypressed then c := readkey;
until ((c > #48) and (c < #54));
case c of
#49 : CambiaNivel;
#50 : CamSonido;
#52 : begin CompruebaMejora; FinJuego; end;
#53 : MuestraPunts;
end;
BorraMenu;
end;
procedure IniciaCampo;
begin
cleardevice;
setcolor(12);
rectangle(20,17,620,462);
rectangle(19,18,621,463);
rectangle(410,2,600,15);
setfillstyle(6,4);
floodfill(320,10,12);
setcolor(7); outtextxy(415,5,'Puntos:');
outtextxy(520,5,'Nivel:');
for c := 1 to 30 do begin
ColaX[c] := 0; ColaY[c] := 0; end;
setcolor(14);
rectangle(106,68, 114,76); ColaX[3] := 8; ColaY[3] := 5;
rectangle(118,68, 126,76); ColaX[2] := 9; ColaY[2] := 5;
rectangle(130,68, 138,76); ColaX[1] := 10; ColaY[1] := 5;
IncrmX := 1; IncrmY := 0; PosX := 11; PosY := 5; NumArray := 3;
BolaX := 15; BolaY := 15; TipoMov := 'D'; basta := false;
PtosTot := 0; PtosPar := 0; mejora := false;
end;
procedure PintaCabeza;
begin
setcolor(9);
rectangle(10+(PosX*12), 8+(PosY*12), 18+(PosX*12), 16+(PosY*12));
setcolor(14);
rectangle(10+(ColaX[1]*12), 8+(ColaY[1]*12), 18+(ColaX[1]*12), 16+(ColaY[1]*12));
end;
procedure BorraCola;
begin
setcolor(0);
rectangle(10+(ColaX[NumArray-1]*12), 8+(ColaY[NumArray-1]*12),
18+(ColaX[NumArray-1]*12), 16+(ColaY[NumArray-1]*12));
for c := NumArray downto 1 do
begin
ColaX[c] := ColaX[c-1];
ColaY[c] := ColaY[c-1];
end;
ColaX[1] := PosX; ColaY[1] := PosY;
end;
procedure DetectaColision;
procedure AvisoChoque;
var t : char;
begin
AbreVentana(200,140,250,100,'GAME OVER');
setcolor(7); outtextxy(215,190,'Se ha chocado!!');
if Sonido then begin
Sound(367); Delay(200*DLY); Sound(352); Delay(200*DLY);
Sound(330); Delay(200*DLY); Sound(313); Delay(455*DLY);
NoSound; end;
outtextxy(215,210,'¨Desea jugar otra vez [S/N]?');
repeat if Keypressed then begin
t := readkey; t := upcase(t); end;
until (t='S') or (t='N');
CompruebaMejora;
if t = 'N' then begin FinJuego; end;
if t = 'S' then basta := true;
end;
var
Num : shortint;
begin
if ((PosX<1) or (PosX>50) or (PosY<1) or (PosY>37)) then
begin
setcolor(12);
circle(14+(ColaX[1]*12), 12+(ColaY[1]*12), 5);
AvisoChoque;
end;
Num := NumArray;
repeat
if ((ColaX[Num] = PosX) and (ColaY[Num] = PosY)) then
begin
setcolor(12);
circle(14+(PosX*12), 12+(PosY*12), 5);
AvisoChoque;
break;
end;
Num := Num - 1;
until Num<3;
if Laberinto[((PosY-1)*50)+PosX] = true then begin
setcolor(12); circle(14+(ColaX[1]*12), 12+(ColaY[1]*12),5);
AvisoChoque; end;
end;
procedure PintaComida;
var
NA : string[6];
begin
setfillstyle(1,0);
bar(478,4, 510,12);
bar(14+(BolaX*12)-2, 12+(BolaY*12)-2, 14+(BolaX*12)+2, 12+(BolaY*12)+2);
PtosTot := PtosPar + PtosTot; PtosPar := MaxPtosPar;
str(PtosTot, NA);
setcolor(15); outtextxy(479,5,NA);
setfillstyle(1,10);
repeat
BolaX := random(49)+1; BolaY := random(36)+1;
until Laberinto[((BolaY-1)*50)+BolaX] = false;
bar(14+(BolaX*12)-2, 12+(BolaY*12)-2, 14+(BolaX*12)+2, 12+(BolaY*12)+2);
if NumArray < 30 then NumArray := NumArray + 1;
if NumArray > 30 then Rtraso := Rtraso - 1;
if Sonido then begin
Sound(1056); Delay(15*DLY); Sound(938); Delay(15*DLY); Sound(734);
Delay(15*DLY); Sound(528); Delay(15*DLY); NoSound; end;
end;
procedure LeeTecla;
procedure TeclaArriba;
begin
if TipoMov <> 'B' then begin
IncrmX := 0; IncrmY := -1; TipoMov := 'A' end
else begin if Sonido then begin
Sound(83); Delay(10*DLY); NoSound; end; end;
if PtosPar > 0 then PtosPar := PtosPar - 1;
end;
procedure TeclaIzquierda;
begin
if TipoMov <> 'D' then begin
IncrmX := -1; IncrmY := 0; TipoMov := 'I' end
else begin if Sonido then begin
Sound(83); Delay(10*DLY); NoSound; end; end;
if PtosPar > 0 then PtosPar := PtosPar - 1;
end;
procedure TeclaDerecha;
begin
if TipoMov <> 'I' then begin
IncrmX := 1; IncrmY := 0; TipoMov := 'D' end
else begin if Sonido then begin
Sound(83); Delay(10*DLY); NoSound; end; end;
if PtosPar > 0 then PtosPar := PtosPar - 1;
end;
procedure TeclaAbajo;
begin
if TipoMov <> 'A' then begin
IncrmX := 0; IncrmY := 1; TipoMov := 'B' end
else begin if Sonido then begin
Sound(83); Delay(10*DLY); NoSound; end; end;
if PtosPar > 0 then PtosPar := PtosPar - 1;
end;
var
t : char;
begin
if Keypressed then
begin
t := readkey;
case t of
#72 : TeclaArriba;
#75 : TeclaIzquierda;
#77 : TeclaDerecha;
#80 : TeclaAbajo;
#27 : Menu;
end;
end;
end;
procedure Juego;
begin
PintaCabeza;
if (BolaX = PosX) and (BolaY = PosY) then
begin
PintaComida;
end;
LeeTecla;
BorraCola;
PosX := PosX + IncrmX; PosY := PosY + IncrmY;
DetectaColision;
LeeTecla;
Delay(Rtraso*DLY);
end;
begin
clrscr; randomize;
IniciaVideo; Presentacion;
repeat
IniciaCampo; EligeLaberinto; CambiaNivel; BorraMenu; PintaComida;
repeat Juego; until basta;
until definal;
closegraph;
end.
Serpiente
Típico juego de la Serpiente escrito en Pascal, con 3 laberintos y 5 niveles de dificultad, en 640x480x16. Guarda mejores puntuaciones.
Descargar adjuntos
COMPARTE ESTE TUTORIAL
COMPARTIR EN FACEBOOK
COMPARTIR EN TWITTER
COMPARTIR EN LINKEDIN
COMPARTIR EN WHATSAPP
Hola Estamos entrando en un nuevo año 2022 y tienes nuevos proyectos, quieres construir una nueva casa, quieres comprar un coche, etc..., para todos tus problemas de financiación. Somos una institución de microfinanzas y te brindamos una oferta de financiamiento rápida y confiable. Si necesita un préstamo rápido, no existe para contactarnos con respecto a su solicitud: https://www.inter-rapide-finance.com/es/ E-mail: [email protected] Gracias...
La dirección de correo de contacto ya no termina en .com, sino en .es.
hola como puedo comprobar si tengo instalado la unidad grafica del pascal
Os comento: este código está hecho para ser compilado bajo Turbo Pascal 7, con la unidad gráfica Graph instalado. Es frecuente encontrar el TP7 sin la unidad gráfica: hay que comprobar que está el fichero graph.tpu. Es el error más común de cuantas personas me preguntan sobre el código. En cuanto a los 102 errores de compilación, me parece que tienes razón, pero la culpa no es del código, sino del portal. Mira la línea: InitGraph(Driver,Modo,.BGI); Las comillas simples ' han sido sustituidas por , y es lo que produce tantos fallos de compilación. (El TP7, por cierto, se queda en el primero). La solución más rápida es eliminar toda aparición de en el código. Y sobre los comentarios, hmmm... no sé, usando tantos procedimientos y funciones yo me aclaraba de lo que hacía el código. Si alguien tiene alguna duda o quiere comentar algo, que envíe un correo electrónico, como ya han hecho algunos!
este juego no sirve para bajar deberia tener comentarios par poder saber que es lo que hace cada funcion y la version porque cuiando intente en mi computadora no daba salia 102 errores
yo lo copie en la versio 7.0 de pascal y no me corre quisiera saber por que? espero un respuesta pronto. gracias.
Joé, que cosas mas raras se encuentra uno cuando pones Victor Barbero Romero en el Google. En realidad buscaba tu dirección de correo para decirte que he encontrado un clon vuestro: www.casas-rurales.tk Ya me registraré algún día en la vuestra...
hola como sabia que el creador de este juego es Victor Barbero pues queria contactar con el pues seguro que se acuerda d mi!!