Pascalda Yılan Oyunu v10

Bu oyun bugune kadar yapılmıs yılan oyunlarının en iyisi cunku cok iyi bir alt yapıya sahip.Oyunun algoritmaları pascalda hazırlayacagınız butun oyunlara yardımcı olabilecek niteliktedir.
{******************************************************************
TURBO PASCAL 7.0
Programme : SnaKe
Version : 1.0
Written By : Deniz Turkan
*******************************************************************}

uses crt,dos,graph;
Const
Sag = #77;
Sol = #75;
Yukari = #72;
Asagi = #80;

Type
Tyilan = Record
x,y : Integer;
adim : Integer;
puan : Integer;
hak : Integer;
end;

Type
Tyem = Record
x,y : Integer;
end;

var
yilan : Array [0..150] of Tyilan;
yem : Tyem;
tus : Char;
yon : Byte;
max : Integer;
renk : Byte;

{-------------------------------------------------------------------}
Procedure baslangic;
var
i : Integer;
begin
Randomize;
for i := getmaxx downto 100 do
begin
if i > getmaxx div 2 - 100 then
setcolor(4)
else setcolor(2);
circle(getmaxx div 2,getmaxy div 2 ,i);
end;
setcolor(10);
outtextxy(getmaxx div 2 - 18, getmaxy div 2 ,'SnaKe');

i := 0;
repeat
if i < 255 then
i := i + 2
else i := 0;
setrgbpalette(0,128,128,i);
until keypressed;
setrgbpalette(0,0,0,0);
cleardevice;
end;

{-------------------------------------------------------------------}

{Girilen degere gore gercek zamanli bekleme olusturan procedure}
Procedure Bekle( sure : Byte );
Var
saat,dakika,saniye,salise : word;
tutulan,hesaplanan : Longint;
begin
gettime(saat,dakika,saniye,salise);
tutulan := salise;
repeat
gettime(saat,dakika,saniye,salise);
hesaplanan := salise;
until (abs(hesaplanan - tutulan) >= sure);
end;
{-------------------------------------------------------------------}
{Girilen degere Gore (True - False) grafik ekranini acan veya kapatan Procedure }
Procedure Grafik(durum : Boolean);
var
gd,gm : Integer;
begin
if durum then
begin
gd := Detect;
initgraph(gd,gm,");
end else
closegraph;
end;

{-------------------------------------------------------------------}
{sayisal degerleri string degerlere cevirme}
function inttostr( n : integer ) : string;
var
s : string[11];
begin
str(n,s);
inttostr := s;
end;

{string degeri sayisal degere cevirir}
function strtoint(n : string) : longint;
var
i : longint;
kod : integer;
begin
val(n,i,kod);
if kod > 0 then strtoint := 0 else
strtoint := i;
end;
{-------------------------------------------------------------------}

{Yem yenildikten sonra yilanin bulundugu koordinatlardan farkli bir yere
tekrar yem atar}
Procedure Yemat ( var yln : array Of Tyilan );
Var
sonuc : Boolean;
i : Byte;
begin
yem.x := 20 + random(getmaxx - 30);
yem.y := 65 + random(getmaxy - 68);
repeat
sonuc := True;
for i := 0 to max do
if ((yln.x+5 >= yem.x-10) and (yln.x+5 <= yem.x+13) and (yln.y >= yem.y-15) and (yln.y <= yem.y+10))
then
begin
yem.x := 20 + random(getmaxx - 30);
yem.y := 65 + random(getmaxy - 68);
sonuc := False;
end;
until sonuc;
for i := 1 to 4 do
begin
setcolor(10);
circle(yem.x,yem.y,i);
end;
end;
{-------------------------------------------------------------------}
Procedure Yemsil;
var
i : Byte;
begin
for i := 1 to 4 do
begin
setcolor(0);
circle(yem.x,yem.y,i);
end;
end;

{-------------------------------------------------------------------}

Procedure Yilan_yap( var yedek_yilan : Array Of Tyilan; x,y,adim : Integer);
Var
i : Byte;
begin
max := 10;
for i := 0 to max do
begin
yedek_yilan.x := x;
yedek_yilan.y := y;
yedek_yilan.adim := adim;
end;
Yedek_yilan[0].Puan := 0;
Yedek_yilan[0].hak := 3;
end;
{-------------------------------------------------------------------}
Procedure Aktar ( var yedek_yilan : Array of Tyilan );
var
i : Byte;
begin
for i := max downto 1 do
begin
yedek_yilan.x := yedek_yilan[i-1].x;
yedek_yilan.y := yedek_yilan[i-1].y;
end;
end;
{-------------------------------------------------------------------}
Procedure Yilan_sil (var yedek_yilan : Array of Tyilan;buyukluk,renk : Byte );
begin
setfillstyle(1,renk);
Bar(yedek_yilan[max].x,yedek_yilan[max].y,yedek_yilan[max].x+buyukluk,yedek_yilan[max].y+buyukluk);
end;
{-------------------------------------------------------------------}
Procedure Yilan_yaz( Var yedek_yilan : Array of Tyilan; buyukluk,renk : Byte);
begin
setfillstyle(6,renk);
Bar(yedek_yilan[0].x,yedek_yilan[0].y,yedek_yilan[0].x+buyukluk,yedek_yilan[0].y+buyukluk);
setcolor(1);
Rectangle(yedek_yilan[0].x,yedek_yilan[0].y,yedek_yilan[0].x+buyukluk,yedek_yilan[0].y+buyukluk);
end;
{-------------------------------------------------------------------}
Procedure Sonuclar( var yedek_yilan : Array Of Tyilan);
begin
setfillstyle(1,4);
bar(getmaxx-120,10,getmaxx-30,40);
setcolor(9);
outtextxy(getmaxx-110,15,'Puan :'+inttostr(Yedek_yilan[0].puan));
outtextxy(getmaxx-110,25,'Hak :'+inttostr(Yedek_yilan[0].hak));

end;
{-------------------------------------------------------------------}
{ Bu procedure yilanin kafasinin kendinden herhangi bir yere carpip
carpmadigini kontrol eder }
Procedure Kendine_carptimi( Var yedek_yilan : array of Tyilan;x,y : Integer);
var
i : Byte;
begin
for i := 1 to max do
if (x = yedek_yilan.x)and(y = yedek_yilan.y)
then
begin
yedek_yilan.adim := 0;
sound(500);
bekle(1);
nosound;
yedek_yilan[0].hak := yedek_yilan[0].hak - 1;
yon := 0;
tus := #0;
sonuclar(yedek_yilan);
Break;
end;
end;

{-------------------------------------------------------------------}
Procedure Yeme_Carptimi( var yedek_yilan : Array of Tyilan ; x,y : Integer);
begin
if (x+5 >= yem.x-10) and (x+5 <= yem.x+13) and (y >= yem.y-15) and (y <= yem.y+10)
then
begin
yemsil;
sound(100);
bekle(1);
nosound;
yemat(yilan);
max := max + 1;
yedek_yilan[0].puan := yedek_yilan[0].puan + 9;
sonuclar(yilan);
end;
end;
{-------------------------------------------------------------------}
{Bu procedure yilanin bas kisminin duvara carpip carpmadigini kontrol eder}
Procedure Duvara_carptimi(var yedek_yilan : Array of Tyilan);
begin
if (yedek_yilan[0].x >= getmaxx - 10) then
begin
yedek_yilan[0].x := 10;
end;
if (yedek_yilan[0].x <= 2) then
begin
yedek_yilan[0].x := getmaxx - 13;
end;
if (yedek_yilan[0].y <= 50) then
begin
yedek_yilan[0].y := getmaxy - 13;
end;
if (yedek_yilan[0].y >= getmaxy - 10) then
begin
yedek_yilan[0].y := 51;
end;
end;

{-------------------------------------------------------------------}
Procedure Ekran;
begin
setcolor(15);
rectangle(1,1,getmaxx,getmaxy);
line(1,50,getmaxx,50);
setfillstyle(1,4);
bar(3,3,getmaxx - 2 ,48);
setcolor(12);
Outtextxy(8,15,'Written By : İsminiz ; ');
Outtextxy(8,25,'e-mail : mailiniz@mail.com');
setcolor(9);
outtextxy(getmaxx-110,15,'Puan :'+inttostr(yilan[0].puan));
outtextxy(getmaxx-110,25,'Hak :'+inttostr(yilan[0].hak));
end;
{-------------------------------------------------------------------}
Procedure Final( var yedek_yilan : Array of Tyilan);
begin
if yedek_yilan[0].puan >= 999 then
begin
setfillstyle(8,8);
bar(1,1,getmaxx,getmaxy);
setcolor(15);
rectangle(1,1,getmaxx-2,getmaxy-2);
setcolor(14);
outtextxy(getmaxx div 2-length('TEBRIKLER OYUNU BITIRDINIZ')*4 , getmaxy div 2 , 'TEBRIKLER OYUNU BITIRDINIZ');
readkey;
grafik(false);
halt;
end;
end;
{-------------------------------------------------------------------}


begin
clrscr;
grafik(True);
baslangic;
yilan_yap(yilan,200,240,13);
yemat(yilan);
ekran;
yon := 1;
repeat
aktar(yilan);
yilan_sil(yilan,10,0);
yilan_yaz(yilan,10,1+random(15));
bekle(1);


if keypressed then tus := Readkey;
if (yilan[0].hak > 0) then
begin
if ( tus = sag ) and (yon <> 2) then yon := 1;
if ( tus = sol ) and (yon <> 1) then yon := 2;
if ( tus = yukari ) and (yon <> 4) then yon := 3;
if ( tus = asagi ) and (yon <> 3) then yon := 4;

if (yon = 1) then inc(yilan[0].x,yilan[0].adim);
if (yon = 2) then dec(yilan[0].x,yilan[0].adim);
if (yon = 3) then dec(yilan[0].y,yilan[0].adim);
if (yon = 4) then inc(yilan[0].y,yilan[0].adim);
if yon<>0 then Kendine_carptimi(yilan,yilan[0].x,yilan[0].y);
yeme_carptimi(yilan,yilan[0].x,yilan[0].y);
Duvara_carptimi(yilan);
final(yilan);
end;

until Tus = #27;
grafik(False);
gotoxy(1,1);
write('Written By : İsminiz ; ');
gotoxy(1,2);
write('mailadresiniz@mail.com');
gotoxy(1,3);
write('* 2005 *');

end.

alıntıdır.

 

Yaptım bir tane.

Written By Franti.

Teşekkürler.

 

kadreş eline emeğine sağlık!!! en yakın zmanda bende yapcam bir tane!!!

 

kardeş eline emeğine sağlık ! allahın izniyle en yakın zamanda bende yapcam bir tane