Programación en Pascal/Ejemplo
El siguiente ejemplo puede ejecutarse tanto en Linux como en Windows (en modo MS-DOS).
Para ejecutarlo en Linux, es necesario instalar la librería svgalib, y ejecutar el programa con permisos de superusuario:
$ sudo ./Serpiente2
Aunque el ejemplo es antiguo y utiliza librerías desfasadas, es un buen ejemplo de lo que se puede hacer con poquito código en Pascal. En otras partes de este curso iremos poniendo ejemplos más modernos usando Lazarus.
program Serpiente2;
(*******************************************
* Por Victor Barbero Romero - Oct. 2.001 *
* vbarbero@movistar.com 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 : smallint;
begin
Driver := VGA; { Modo := VGAHi; }
Modo := G640x480x256; { Cambiado debido a problemas con algunas resoluciones gráficas }
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.