Code:
{
snake.pas
Copyright 2014 Markus Mangold <cybermonkey@retrogamecoding.org>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
MA 02110-1301, USA.
}
{$ifdef Windows}
{$apptype gui}
{$endif}
program snake;
uses ptccrt,ptcgraph,lazutf8sysutils,sysutils;
type TBody = record
x,y: array of integer;
xoffset,yoffset,xcount,ycount,width,height,length:integer ;
direction: string;
end;
type TApple = record
x,y,xoffset,yoffset,xcount,ycount,width,height:integer;
end;
type TScore = record
score:integer;
name:ansistring;
date:ansistring;
end;
var gd,gm:smallint;
page,ch,i:integer;
TICK_INTERVAL:integer = 1000 div 60;
next_time : cardinal = 0;
score:integer = 0;
snake:TBody;
bait:TApple;
speed:real=50;
lasttime:integer = 0;
nowtime:integer=0;
seconds:integer = 10;
endgame:boolean = false;
name: string;
hiscore: array [1..10] of TScore;
const CRSLEFT = 19200;
CRSRIGHT = 19712;
CRSUP = 18432;
CRSDOWN = 20480;
FUNCTION GetKey:LONGINT;
VAR InKey: LONGINT;
BEGIN
InKey:=ORD(ReadKey);
IF InKey=0 THEN InKey:=ORD(ReadKey) SHL 8;
result:=InKey;
END;
function grinput (xold,y,lengthy:integer):ansistring;
var key,x,ins:integer;
ch:char;
answer:ansistring;
mysize:word;
getsize:TextSettingsType;
begin
GetTextSettings (getsize);
mysize:=getsize.charsize*8;
answer:='';
ins:=(length (answer)+1);
x:=xold;
repeat
setfillstyle (solidfill,getcolor());
if ins > length (answer) then begin
bar (x,y,x+mysize-1,y+mysize);
end else begin
bar (x,y+mysize-1,x+mysize-1,y+mysize);
end;
key:=getkey;
ch:=chr(key);
setfillstyle (solidfill,getbkcolor());
bar (x,y,x+mysize-1,y+mysize);
if key = 3 then begin
closegraph;
halt (0);
end;
if (key <> 8) and (key <>13) and (key<>18432) and (key<>19712) and (key<>19200) and (key<>20480) and (key<>15104) and (key<>15360)and (key<>15616)and (key<>15872)and (key<>16128)and (key<>16384)and (key<>16640) and (key<>21248) and (key<>20992) and (key<>18176) and (key<>18688) and (key<>21248) and (key<>20224) and (key<>20736) and (key<>16896) and (key<>17152) and (key<>17408) and (length (answer)<=lengthy-1) then begin
insert (ch,answer,ins);
x:=x+mysize;
ins:=ins+1;
end;
if key=15104 then begin
insert (chr (142),answer,ins);
x:=x+mysize;
ins:=ins+1;
end;
if key=15360 then begin
insert (chr(153),answer,ins);
ins:=ins+1;
x:=x+mysize;
end;
if key=15616 then begin
insert (chr(154),answer,ins);
ins:=ins+1;
x:=x+mysize;
end;
if key=15872 then begin
insert (chr(225),answer,ins);
ins:=ins+1;
x:=x+mysize;
end;
if key=16128 then begin
insert (chr(132),answer,ins);
x:=x+mysize;
ins:=ins+1;
end;
if key=16384 then begin
insert (chr(148),answer,ins);
ins:=ins+1;
x:=x+mysize;
end;
if key=16640 then begin
insert (chr(129),answer,ins);
ins:=ins+1;
x:=x+mysize;
end;
if key=19200 then begin
if (x >= xold) and (ins>1) then begin
ins:=ins-1;
x:=x-mysize;
if ins <=1 then begin
ins:=1;
end;
end;
end;
if key=19712 then begin
if (x>= xold) and (ins<=length (answer)) then begin
ins:=ins+1;
x:=x+mysize;
end;
end;
if key=8 then begin
if x >= xold then begin
x:=x-mysize;
ins:=ins-1;
delete (answer,ins,1);
end;
if ins <=1 then begin
ins:=1;
end;
end;
if key=21248 then begin
if x >= xold then begin
delete (answer,ins,1);
end;
if ins <=1 then begin
ins:=1;
end;
end;
if key=18176 then begin
x:=xold;
ins:=1;
end;
if key=20224 then begin
x:=(length (answer))*mysize+xold;
ins:=(length (answer)+1);
end;
if x<= xold then begin
x:=xold;
end;
setfillstyle (solidfill,getbkcolor());
bar (x,y,xold*mysize,y+mysize);
moveto (xold,y);
OutText (answer);
until (key=13) or (key=27) ;
Result:=answer;
end;
procedure InitHighScores;
var i:byte;
begin
for i:= 1 to 10 do begin
hiscore[i].score:=0;
hiscore[i].name:='No Name';
hiscore[i].date:=FormatDateTime('yyyy-mm-dd',now);
end;
end;
procedure SortHighScores;
var getauscht : boolean;
i, temp : integer;
tempdate,tempstr : ansistring;
begin
repeat
getauscht:=false;
for i:=1 to 9 do
if hiscore[i].score < hiscore[i+1].score then begin
temp:=hiscore[i].score;
tempstr:=hiscore[i].name;
tempdate:=hiscore[i].date;
hiscore[i].score:=hiscore[i+1].score;
hiscore[i].name:=hiscore[i+1].name;
hiscore[i].date:=hiscore[i+1].date;
hiscore[i+1].score:=temp;
hiscore[i+1].name:=tempstr;
hiscore[i+1].date:=tempdate;
getauscht:=true;
end;
until getauscht = false;
end;
procedure LoadHighscores;
var userfile: text;
filename:ansistring;
begin
InitHighScores;
filename := 'snakehigh.dat';
if fileexists (filename) = false then begin
assign (userfile, filename);
begin
{$I-}
rewrite (userfile);
{$I+}
end;
for i:= 1 to 10 do begin
writeln (userfile,hiscore[i].score);
writeln (userfile,hiscore[i].name);
writeln (userfile,hiscore[i].date);
end;
If (IOResult <> 0) then
Begin
Writeln('ERROR: File not found');
closegraph;
halt(0);
end;
close (userfile);
end;
if fileexists (filename) then begin
assign (userfile, filename);
begin
{$I-}
reset (userfile);
{$I+}
end;
for i:= 1 to 10 do begin
readln (userfile,hiscore[i].score);
readln (userfile,hiscore[i].name);
readln (userfile,hiscore[i].date);
end;
If (IOResult <> 0) then
Begin
Writeln('ERROR: File not found');
closegraph;
halt(0);
end;
close (userfile);
end;
end;
procedure SaveHighScores;
var userfile: text;
filename:ansistring;
begin
filename := 'snakehigh.dat';
if fileexists (filename) then begin
assign (userfile, filename);
begin
{$I-}
rewrite (userfile);
{$I+}
end;
for i:= 1 to 10 do begin
writeln (userfile,hiscore[i].score);
writeln (userfile,hiscore[i].name);
writeln (userfile,hiscore[i].date);
end;
If (IOResult <> 0) then
Begin
Writeln('ERROR: File not found');
closegraph;
halt(0);
end;
close (userfile);
end;
end;
procedure DisplayHighScores;
var i:byte;
begin
SetTextStyle(DefaultFont, HorizDir,3);
OutTextXY (200,50,'HIGHSCORES');
for i:=1 to 10 do begin
OutTextXY (40,120+i*30,hiscore[i].name);
OutTextXY (320,120+i*30,IntToStr (hiscore[i].score));
OutTextXY (550,120+i*30,hiscore[i].date);
end;
OutTextXY (20,600,'Press any key to go on!');
end;
function hrgb (red,green,blue:byte):word;
begin
result:= (((red Shr 3) Shl 11) + ((green Shr 2) Shl 5) + (blue Shr 3));
end;
procedure SetFrameTimer (frames:integer);
begin
if frames = 0 then
frames := 1;
TICK_INTERVAL:=1000 div frames;
end;
function TimeLeft : UInt32;
var
now : UInt32;
begin
now := gettickcount64;
if next_time <= now then
begin
next_time := now + TICK_INTERVAL;
result := 0;
exit;
end;
result := next_time - now;
end;
BEGIN
randomize;
gd:=d16bit;
gm:=m1024x768;
initgraph (gd,gm,'');
snake.xoffset:=111;
snake.yoffset:=111;
snake.xcount:=10;
snake.ycount:=10;
snake.width:=8;
snake.height:=8;
snake.direction :='right';
snake.length := 1;
setlength (snake.x, snake.length+1);
setlength (snake.y, snake.length+1);
snake.x [1]:=5;
snake.y [1]:=5;
bait.x:=30;
bait.y:=30;
bait.xoffset:=111;
bait.yoffset:=111;
bait.xcount:=10;
bait.ycount:=10;
bait.width:=8;
bait.height:=8;
setbkcolor (hrgb (0,0,150));
cleardevice;
ch:=0;
page:=0;
LoadHighScores;
setcolor (65535);
DisplayHighScores;
readkey;
cleardevice;
SetTextStyle(DefaultFont, HorizDir,8);
setcolor (hrgb (250,0,0));
OutTextXY (10,10,'SNAKE');
setcolor (hrgb (250,250,0));
OutTextXY (15,15,'SNAKE');
SetTextStyle(DefaultFont, HorizDir,2);
SetFrameTimer (60);
setcolor (65535);
OutTextXy (0,160,'Please enter your name: ');
name := grinput (380,160,20);
LoadHighscores;
SortHighscores;
lasttime:=gettickcount64();
repeat
nowtime:=gettickcount64();
if nowtime>=lasttime+1000 then begin
lasttime:=nowtime;
seconds:=seconds-1;
if seconds <=0 then begin
bait.x := random (72);
bait.y := random (52);
seconds := 10;
score := score - 3;
end;
end;
setactivepage (page);
cleardevice;
if keypressed then begin
ch:=getkey();
case ch of
CRSLEFT: snake.direction := 'left';
CRSRIGHT:snake.direction := 'right';
CRSUP: snake.direction := 'up';
CRSDOWN: snake.direction := 'down';
27:endgame:=true;
112: readkey();
3:begin
closegraph;
halt;
end;
end;
end;
if (snake.x[1]=bait.x) and (snake.y[1]=bait.y) then begin
score := score + 1;
bait.x := random (72);
bait.y := random (52);
snake.length:=snake.length + 1;
setlength (snake.x, snake.length+1);
setlength (snake.y, snake.length+1);
speed := speed - 0.2;
nowtime:=gettickcount64();
seconds := 10;
end;
if snake.direction ='right' then begin
for i:=snake.length downto 2 do begin
snake.x[i]:=snake.x[i-1];
snake.y[i]:=snake.y[i-1];
end;
snake.x[1]:=snake.x[1] + 1;
sleep (round(speed));
end;
if snake.direction ='down' then begin
for i:=snake.length downto 2 do begin
snake.x[i]:=snake.x[i-1];
snake.y[i]:=snake.y[i-1];
end;
snake.y[1]:=snake.y[1] + 1;
sleep (round(speed));
end;
if snake.direction ='left' then begin
for i:=snake.length downto 2 do begin
snake.x[i]:=snake.x[i-1];
snake.y[i]:=snake.y[i-1];
end;
snake.x[1]:=snake.x[1] - 1;
sleep (round(speed));
end;
if snake.direction ='up' then begin
for i:=snake.length downto 2 do begin
snake.x[i]:=snake.x[i-1];
snake.y[i]:=snake.y[i-1];
end;
snake.y[1]:=snake.y[1] - 1;
sleep (round(speed));
end;
for i:=2 to snake.length do begin
if (snake.x[1]=snake.x[i]) and (snake.y[1]=snake.y[i]) then begin
endgame := true;
end;
end;
if snake.x[1] < 0 then begin
endgame:=true;
end;
if snake.x[1] > 72 then begin
endgame:=true
end;
if snake.y[1] < 0 then begin
endgame:=true;
end;
if snake.y[1] > 52 then begin
endgame:=true;
end;
if score < 0 then begin
endgame := true;
end;
setcolor (hrgb (255,0,0));
setfillstyle (solidfill,getcolor());
fillellipse ((bait.xoffset+bait.x*bait.xcount)+bait.width div 2,(bait.yoffset+bait.y*bait.ycount)+bait.width div 2,bait.width div 2,bait.width div 2);
setcolor (hrgb (255,255,0));
setfillstyle (solidfill,getcolor());
for i:=1 to snake.length do begin
bar (snake.xoffset+snake.x[i]*snake.xcount,snake.yoffset+snake.y[i]*snake.ycount,(snake.xoffset+snake.x[i]*snake.xcount)+snake.width,(snake.yoffset+snake.y[i]*snake.ycount)+snake.height);
end;
setcolor (65535);
setfillstyle (solidfill,getcolor());
bar (100,100,850,110);
bar (100,100,110,650);
bar (100,641,850,650);
bar (841,100,850,650);
OutTextXY (100,80,name);
OutTextXY (700,80,'Score: '+IntToStr(score));
OutTextXY (500,80,'Time: '+IntToStr(seconds));
setvisualpage (page);
inc (page);
if page >1 then begin
page:=0;
end;
sleep (timeleft());
until endgame = true;
setcolor (65535);
OutTextXY (GetMaxX() div 2-100,GetMaxY() div 2-8,'GAME OVER!');
OutTextXY (GetMaxX() div 2-200,GetMaxY() div 2+8,'Press any key to exit.');
readkey;
if score > hiscore[10].score then begin
hiscore[10].score := score;
hiscore [10].name := name;
hiscore [10].date := FormatDateTime ('yyyy-mm-dd',now);
SortHighScores;
SaveHighScores;
end;
cleardevice;
DisplayHighScores;
readkey;
closegraph;
END.
Bookmarks