Another simple snake game (no OOP)

[Cybermonkey]

Since I don't want to hijack Roland's thread i thought I might post my own snake game made 4 years ago. It uses the ptcgraph library. It has a highscore table and a graphical input function (which needs almost half of the source code). It does not use objects only types. Please note, for compiling the lazutf8sysutils unit is needed which usually not comes with a plain FPC installation. Besides of that you do not need Lazarus for compiling. It should compile on both Windows and Linux. I compile it usually with

fpc snake.pas -Sd -O2
Gameplay might be a little bit different from classical snake. One has only 10 seconds to get the bait. If you get it 1 point will be added to your score. If you fail 3 points are subtracted from your score. There is only one life.

A screenshot:
1504

And the source:

{
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:int eger;
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.

[SilverWarior]

Impressive!
You know what would be nice? If you could go and comment your code a bit so that it would become more understandable for beginners.
Too often I see little pieces of code that have potential to serve as learning examples but don't have any comments and therefore are not suitable for learning for beginners. Well not without the need to load this code into debugger and walk through it step by step.

[Roland Chastain]

Please note, for compiling the lazutf8sysutils unit is needed which usually not comes with a plain FPC installation.

Hello! Thank you for your code. In fact, the LazUtf8SysUtils unit doesn't seem to be used. ;)

[Roland Chastain]

Very nice program! I think I will copy your high scores management code. :)

The graphic input routine is also very useful. Where did you take these key values ? Aren't there constants declared somewhere for these values ?


if (key <> 8) and (key <> 13) and (key <> 18432) and (key <> 19712) and
(key <> 19200) and (key <> 20480) and (key <> 15104) and (key <> 15360)

[Cybermonkey]

Hello! Thank you for your code. In fact, the LazUtf8SysUtils unit doesn't seem to be used. ;)

Actually you are right. Strange enough, I thought I need it for gettickcount64 ...

[Cybermonkey]

Very nice program! I think I will copy your high scores management code. :)

The graphic input routine is also very useful. Where did you take these key values ? Aren't there constants declared somewhere for these values ?


if (key <> 8) and (key <> 13) and (key <> 18432) and (key <> 19712) and
(key <> 19200) and (key <> 20480) and (key <> 15104) and (key <> 15360)

I can't remember anymore ... Maybe I wrote a simple program which outputs the values. At least it isn't on my harddisk anymore.

[Roland Chastain]

Maybe I wrote a simple program which outputs the values. At least it isn't on my harddisk anymore.

I see. Thank you for your answer.

[Cybermonkey]

By the way, maybe I can advertise my Lua interpreter in this case. ;)
It's completely made with Free Pascal and the ptcgraph unit. You can find it on the following site: http://cmlua.retrogamecoding.org/

Here's a little demonstation


https://www.youtube.com/watch?v=JN-vjZZ3dUM (http://cmlua.retrogamecoding.org/)

[SilverWarior]

By the way, maybe I can advertise my Lua interpreter in this case. ;)

No you should create a new thread in "Your projects" section for this instead. Post about LUA interpreter is actually off-topic in here and will thus probably be overlooked by most people.
By creating a separate thread you maximize the chance for other people to learn about the existence of your LUA interpreter. And I think several members of PGD will be very interested in it since they have desire to add LUA scripting support to their games/game engines.