{ SNAKE.PAS                                                         }
{ SNAKE-Game                                                        }
{                                                                   }
{ Probeer de blokjes te pakken zonder                               }
{   tegen je staart te botsen                                       }
{                                                                   }
{ Druk op een pijltje of de spatie om te                            }
{   beginnen of druk op een andere toets                            }
{   om te stoppen.                                                  }
{                                                                   }
{ Author: Unknown                                                   }
{ Datum: 20.01.2009                            http://www.trsek.com }

program snake;
uses crt, keyboard, strings;
const TIMEA:integer = 10;
const TIMEB:integer = 0;
const GROWSIZE:integer = 1;
{-------------------------------------------------------}
{	if TIMEA is high and TIMEB is low then		}
{	are the wait time on some verry high.		}
{	but if TIMEA is low and TIMEB is high then	}
{	it detect some keys not.			}
{-------------------------------------------------------}
type wurm = array[0..20] of array[0..20] of longint;
var i,j:integer;
procedure show_screen (scherm:string);
var ch,ch1,ch3,ch2:char;
begin
	if (scherm = 'welkom') then
	begin
		clrscr;
		writeln('                                        ');
		writeln('               SNAKE-Game               ');
		writeln('                                        ');
		writeln(' Probeer de blokjes te pakken zonder    ');
		writeln('   tegen je staart te botsen            ');
		writeln('                                        ');
		writeln(' Druk op een pijltje of de spatie om te ');
		writeln('   beginnen of druk op een andere toets ');
		writeln('   om te stoppen.                       ');
		writeln('                                        ');
	end
	else if (scherm = 'in_game0') then
	begin
		ch := chr(205);
		ch1 := chr(186);
		window(20,19,44,44);
		textbackground(black);
		textcolor(white);
		writeln('     ');
		writeln(' ',ch,ch,chr(187),' ');
		writeln('   ',ch1,' ');
		writeln(' ',ch,ch,chr(185),' ');
		writeln('   ',ch1,' ');
		writeln(' ',ch,ch,chr(188),' ');
		writeln('     ');
	end
	else if (scherm = 'in_game1') then
	begin
		ch := chr(205);
		ch1 := chr(186);
		window(20,19,44,44);
		textbackground(black);
		textcolor(white);
		writeln('     ');
		writeln(' ',ch,ch,chr(187),' ');
		writeln('   ',ch1,' ');
		writeln(' ',chr(201),ch,chr(188),' ');
		writeln(' ',ch1,'   ');
		writeln(' ',chr(200),ch,ch,' ');
		writeln('     ');
	end
	else if (scherm = 'in_game2') then
	begin
		ch := chr(186);
		window(20,19,44,44);
		textbackground(black);
		textcolor(white);
		writeln('     ');
		writeln('  ',chr(187),'  ');
		for i := 0 to 3 do writeln('  ',ch,'  ');	
		writeln('     ');
	end
	else if (scherm = 'in_game3') then
	begin
		window(3,3,45,45);
		textcolor(darkgray);
		ch := chr(218);
		ch1 := chr(191);
		ch2 := chr(192);
		ch3 := chr(217);
		for i := 0 to 20 do
		begin
			for j := 0 to 20 do write(ch,ch1);
			writeln;
			for j := 0 to 20 do write(ch2,ch3);
			writeln;
		end;
		textcolor(black);
		gotoxy(1,1);
	end
	else
	begin
		writeln('ERROR');
	end;
	window(3,3,44,44);
	textcolor(black);
	textbackground(white);
end;
procedure init;
begin
	cursoroff;
	randomize;
	textmode(CO80 + Font8x8);
	textbackground(green);
	clrscr;
	window(2,2,45,45);
	textcolor(black);
	textbackground(red);
	clrscr;
	initkeyboard;
	window(3,3,44,44);
	textbackground(white);
	show_screen('welkom');
end;
procedure game_move (var arr:wurm; const dir:char; var lenght:integer);
var stop:boolean = False; var i,j,x,y,r:integer; var loc:array[0..1] of integer;
begin
	for i := 0 to 20 do
	begin
		for j := 0 to 20 do
		begin
			if (arr[i][j] = 2) and not (stop) then
			begin
				x    := i;    {X}
				y    := j;    {Y}
				stop := True;
			end;			
		end;
	end;
	if (stop) then
	begin
		loc[0] := x;
		loc[1] := y;
		if (dir = 'l') and (x = 0) then
		begin
			x := 20;
		end
		else if (dir = 'r') and (x = 20) then
		begin
			x := 0;
		end
		else if (dir = 'u') and (y = 0) then
		begin
			y := 20;
		end
		else if (dir = 'd') and (y = 20) then
		begin
			y := 0;
		end
		else if (dir = 'd') then
		begin
			y := y + 1;
		end	
		else if (dir = 'u') then
		begin
			y := y - 1;
		end	
		else if (dir = 'l') then
		begin
			x := x - 1;
		end	
		else
		begin
			x := x + 1;
		end;
		if (arr[x][y] = 0) then
		begin
			for i := 0 to 20 do
			begin
				for j := 0 to 20 do
				begin
					if (arr[i][j] = (lenght + 3)) then
					begin
						arr[i][j] := arr[i][j] + GROWSIZE;
					end		
					else if (arr[i][j] > 1) and (arr[i][j] < (lenght + 3)) then
					begin
						arr[i][j] := arr[i][j] + 1;
					end;			
				end;
			end;
			arr[x][y] := 2;
			lenght := lenght + GROWSIZE;
			r := random(400);
			repeat
			begin
				for i := 0 to 20 do
				begin
					for j := 0 to 20 do
					begin
						if (arr[i][j] = 1) or (arr[i][j] > (lenght + 1)) then
						begin
							if (r = 0) then
							begin
								arr[i][j] := 0;
								r := r - 1;
							end
							else if not (r = -1) then
							begin
								r := r - 1;
							end;
						end;			
					end;
				end;
			end
			until (r = -1);
		end
		else if (arr[x][y] = 1) or (arr[x][y] > (lenght + 1)) then
		begin
			for i := 0 to 20 do
			begin
				for j := 0 to 20 do
				begin
					if (arr[i][j] > 1) and (arr[i][j] < (lenght + 3)) then
					begin
						arr[i][j] := arr[i][j] + 1;
					end;			
				end;
			end;
			arr[x][y] := 2;
		end
		else
		begin {Je bent dood}
			for i := 0 to 20 do
			begin
				for j := 0 to 20 do
				begin
					arr[i][j] := 1;			
				end;
			end;
			lenght := 0;
		end;
	end
	else
	begin
		writeln('ERROR');
	end;	
end;
procedure game_vieuw(const arr:wurm;const l:integer);
var ch:array[0..3] of char;
begin
	ch[0] := chr(218);
	ch[1] := chr(191);
	ch[2] := chr(192);
	ch[3] := chr(217);
	window(3,3,45,45);
	for i := 0 to 20 do
	begin
		for j := 0 to 20 do
		begin
			if (arr[i][j] = 2) then
			begin
				textbackground(red);
				textcolor(yellow);
			end
			else if (arr[i][j] > 1) and (arr[i][j] < (l + 3)) then
			begin
				textbackground(yellow);
				textcolor(red);
			end
			else if (arr[i][j] = 0) then
			begin
				textbackground(green);
				textcolor(white);
			end
			else
			begin
				textbackground(white);
				textcolor(darkgray);
			end;
			gotoxy(i * 2 + 1,j * 2 + 1);
			writeln(ch[0],ch[1]);
			gotoxy(i * 2 + 1,whereY);
			writeln(ch[2],ch[3]);
		end;
	end;
	window(3,3,44,44);
	textcolor(black);
	textbackground(white);
end;
procedure game_reset(var arr:wurm; var l:integer);
begin
	for i := 0 to 20 do
	begin
		for j := 0 to 20 do
		begin
			arr[i][j] := 1;
		end;
	end;
	arr[18][19] := 2;
	arr[19][19] := 3;
	arr[1][18]  := 0;
	l := 3;
end;
procedure game_over(score:integer);
var ch:char;
begin
	window(15,15,44,44);
	textbackground(blue);
	write(chr(201));
	ch := chr(205);
	for i := 0 to 13 do
	begin
		write(ch);
	end;
	ch := chr(186);
	writeln(chr(187));
	writeln(ch,'  GAME OVER   ',ch);
	writeln(ch,'              ',ch);
	writeln(ch,' Druk  op de  ',ch);
	writeln(ch,' spatiebalk   ',ch);
	writeln(ch,' om  opnieuw  ',ch);
	writeln(ch,' te beginnen. ',ch);
	writeln(ch,' score:       ',ch);
	gotoxy(10,8);
	writeln(score);
	write(chr(200));
	ch := chr(205);
	for i := 0 to 13 do
	begin
		write(ch);
	end;
	writeln(chr(188));
	window(3,3,44,44);
end;
function game_input(k1:tKeyEvent;dir:char):char;
var K:tKeyEvent;var key:string;
begin
	k := pollkeyevent;
	if not (k = 0) then
	begin
		key := keyeventtostring(translatekeyevent(getkeyevent));
	end
	else if not (k1 = 0) then
	begin
		key := keyeventtostring(translatekeyevent(k1));
	end;
	if not (key = '') then
	begin
		if (key = 'Left') and not (dir = 'r') then
		begin
			dir := 'l';
		end
		else if (key = 'Up') and not (dir = 'd') then
		begin
			dir := 'u';
		end
		else if (key = 'Down') and not (dir = 'u') then
		begin
			dir := 'd';
		end
		else if (key = 'Right') and not (dir = 'l') then
		begin
			dir := 'r';
		end;
	end;
	game_input := dir;
end;
function game_wait:boolean;
var k:tKeyEvent;
begin
	game_wait := true;
	repeat
	begin
		k := pollkeyevent;
	end
	until not (k = 0);
	K := translatekeyevent(getkeyevent);
	if(keyeventtostring(k) = ' ') then
	begin
		textcolor(black);
		textbackground(white);
		show_screen('welkom');
		repeat	
		begin	
			K := pollkeyevent;
		end
		until not (keyeventtostring(translatekeyevent(k)) = ' ');
		game_wait := False;
	end;
end;
var k,k1:tKeyEvent;
var key:string;
var stop:boolean = False;
var old:integer;
var map:wurm;
var l:integer = 3;
var dir:char = 'l';
var temp:char = 'l';
var die:boolean;
begin
	{ INIT }
		init();
		for i := 0 to 20 do
		begin
			for j := 0 to 20 do
			begin
				map[i][j] := 1;
			end;
		end;
		map[18][19] := 2;
		map[19][19] := 3;
		map[19][18] := 4;
		map[19][17] := 5;
		map[1][18]  := 0;
	{ INIT end }
	repeat
	begin
		gotoxy(20,whereY);
		cursoron;
		repeat
		begin
			k := pollkeyevent;
		end
		until not (k = 0);
		cursoroff;
		key := keyeventtostring(translatekeyevent(getkeyevent));
		if (key = 'Left') then
		begin
			dir := 'l';
		end
		else if (key = ' ') then
		begin
			dir := 'l';
		end
		else if (key = 'Up') then
		begin
			dir := 'u';
		end
		else if (key = 'Down') then
		begin
			dir := 'd';
		end
		else if (key = 'Right') then
		begin
			dir := 'r';
		end
		else
		begin
			stop := true;
		end;
		if not (stop) then
		begin
			lowvideo;
			show_screen('in_game3');
			game_vieuw(map,l);
			show_screen('in_game0');
			delay(1000);
			show_screen('in_game1');
			delay(1000);
			show_screen('in_game2');
			delay(1000);
			k1 := pollkeyevent;
			die := False;
			repeat
				begin
					{invoer}
					dir := game_input(k1,dir);
					{Verwerking}
					game_move(map,dir,l);
					if (l = 0) then
					begin
						die := true;
					end
					else
					begin
						game_vieuw(map,l);
						old := l;
					end;
					for i := 0 to TIMEA do
					begin
						k := pollkeyevent;
						if not (k = 0) then k1 := getkeyevent;
						delay(TIMEB);
					end;
				end
			until die;
			normvideo;
			game_over(old);
			game_reset(map,l);
			stop := game_wait;
		end;
	end
	until stop;
	donekeyboard;
	clrscr;
end.