Mega Code Archive
Yılan oyunu
<![CDATA[
Alıntıdır
unit untGame;
interface
uses
Windows, SysUtils, Classes, Controls, Forms, Menus,
ExtCtrls, StdCtrls, Buttons, ComCtrls, Dialogs,
Graphics;
//BTOdeum;
type
TSnakeDirection = (sdUp, sdDown, sdLeft, sdRight);
TfrmGame = class(TForm)
MenuGame: TMainMenu;
mnuGame: TMenuItem;
mnuNew: TMenuItem;
mnuPause: TMenuItem;
mnuContinue: TMenuItem;
N1: TMenuItem;
mnuExit: TMenuItem;
mnuHelp: TMenuItem;
mnuAbout: TMenuItem;
TmrSnake: TTimer;
mnuOptions: TMenuItem;
mnuAlways: TMenuItem;
N2: TMenuItem;
mnuSettings: TMenuItem;
mnuFinish: TMenuItem;
N3: TMenuItem;
StatusGame: TStatusBar;
Easy1: TMenuItem;
VeryEasy1: TMenuItem;
Medium1: TMenuItem;
Advanced1: TMenuItem;
Expert1: TMenuItem;
Professional1: TMenuItem;
when_to_move_target: TMenuItem;
Sound1: TMenuItem;
Never1: TMenuItem;
N601: TMenuItem;
N801: TMenuItem;
N1001: TMenuItem;
N1201: TMenuItem;
N1401: TMenuItem;
N1601: TMenuItem;
N401: TMenuItem;
ViewHighScores1: TMenuItem;
N4: TMenuItem;
HowtoPlay1: TMenuItem;
Borders1: TMenuItem;
PntGame: TPanel;
PntTarget: TPanel;
procedure PutStatus(S: string; Index: Integer);
procedure mnuExitClick(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure show_panel1;
procedure TmrSnakeTimer(Sender: TObject);
procedure read_inifile;
procedure save_inifile;
procedure FormCreate(Sender: TObject);
procedure mnuAlwaysClick(Sender: TObject);
procedure mnuAboutClick(Sender: TObject);
procedure mnuPauseClick(Sender: TObject);
procedure mnuContinueClick(Sender: TObject);
procedure mnuGameClick(Sender: TObject);
procedure DrawTarget;
procedure mnuNewClick(Sender: TObject);
procedure mnuFinishClick(Sender: TObject);
function NewPointIsValid(X, Y: Integer):Boolean;
function BobyInBody(X, Y: Integer):Boolean;
procedure SetAnyLevelClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure SetAnyTimeToWait(Sender: TObject);
procedure ViewHighScores1Click(Sender: TObject);
procedure HowtoPlay1Click(Sender: TObject);
procedure SetSoundMenu;
procedure Sound1Click(Sender: TObject);
procedure SetBordersMenu;
procedure Borders1Click(Sender: TObject);
private
cDir : TSnakeDirection;
Parts : array [0..600] of TSpeedButton;
Body_pieces, Level,
CountToWaitBeforeMovingTarget,
TimeToWaitBeforeMovingTarget : Integer;
score : longint;
Playing, Exec, want_sounds, always_on_top,
game_over, game_paused, want_borders : Boolean;
public
{ Public declarations }
end;
var
frmGame: TfrmGame;
const
W: Integer = 16;
H: Integer = 16;
MAX_X: Integer = 30;
MAX_Y: Integer = 20;
TimeToWaitBase = 20; // time to wait values in menu
// start at TimeToWaitBase + 20 (interval between values)
DefaultTimeToWaitBeforeMovingTarget = 120;
Starting_body_pieces = 4; // add 1 (zero based)
implementation
{$R *.DFM}
uses
untMyIniFiles, untHiscores;
{----------------------------------------------------------}
procedure TfrmGame.PutStatus(S: string; Index: Integer);
begin
StatusGame.Panels[Index].Text:=S;
end; { PutStatus }
{----------------------------------------------------------}
procedure TfrmGame.mnuExitClick(Sender: TObject);
begin
Close;
end; { mnuExitClick }
{----------------------------------------------------------}
procedure TfrmGame.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_LEFT:
cDir:=sdLeft;
VK_RIGHT:
cDir:=sdRight;
VK_UP:
cDir:=sdUp;
VK_DOWN:
cDir:=sdDown;
end;
end; { FormKeyDown }
{----------------------------------------------------------}
procedure TfrmGame.show_panel1;
var
str1 : string;
begin
str1 := Format('Level %d Score: %d Parts: %d',
[Level, score, Body_pieces + 1 ]);
if want_borders then
str1 := str1 + ' Borders ON'
else
str1 := str1 + ' Borders OFF';
if game_paused then
str1 := str1 + ' Game Paused (press F4)'
else
if game_over then
str1 := 'Game Over (press F1 for new game)'
else
begin
if TimeToWaitBeforeMovingTarget = 0 then
str1 := str1 + ' Target Never Moves'
else
str1 := str1 + ' Move Target in: ' +
inttostr(TimeToWaitBeforeMovingTarget-
CountToWaitBeforeMovingTarget);
end;
PutStatus(str1,0);
end; { show_panel1 }
{----------------------------------------------------------}
procedure TfrmGame.TmrSnakeTimer(Sender: TObject);
{..........................................................}
function PntInTarget(X,Y: Integer):Boolean;
begin
Result:=(PntTarget.Left = X) and (PntTarget.Top = Y);
end; { PntInTarget }
{..........................................................}
procedure CreateNewPart(Index, ALeft, ATop: Integer);
begin
Parts[Index]:=TSpeedButton.Create(Self);
Parts[Index].Parent:=PntGame;
Parts[Index].SetBounds(ALeft,ATop,W,H);
Parts[Index].Enabled:=False;
Parts[Index].Visible:=True;
show_panel1;
end; { CreateNewPart }
{..........................................................}
var
LastSnake, FirstSnake : TSpeedButton;
i, NewLeft, NewTop, W_delta, H_delta : Integer;
begin
if Exec then
Exit;
Exec:=True;
if TimeToWaitBeforeMovingTarget > 0 then
begin
CountToWaitBeforeMovingTarget :=
CountToWaitBeforeMovingTarget + 1 mod TimeToWaitBeforeMovingTarget;
show_panel1;
if CountToWaitBeforeMovingTarget >= TimeToWaitBeforeMovingTarget then
// move the target
DrawTarget;
end;
FirstSnake:=Parts[Body_pieces];
LastSnake:=Parts[0];
W_delta := 0;
H_delta := 0;
case cDir of
sdLeft :
W_delta := -W;
sdRight :
W_delta := W;
sdUp :
H_delta := -H;
sdDown :
H_delta := H;
end; // case
NewLeft:=FirstSnake.Left + W_delta;
NewTop:=FirstSnake.Top + H_delta;
if not want_borders then
begin
if NewLeft < 0 then
NewLeft := (Max_X - 1) * W
else
if NewLeft >= PntGame.Width then
NewLeft := 0;
if NewTop < 0 then
NewTop := (Max_Y - 1) * H
else
if NewTop >= PntGame.Height then
NewTop := 0;
end;
if not NewPointIsValid(NewLeft,NewTop) then
Exit;
if PntInTarget(NewLeft, NewTop) then
begin
Body_pieces:=Body_pieces + 1;
if want_sounds then
//BTBeeper1.BeepFor( 500,10 );
CreateNewPart(Body_pieces,NewLeft,NewTop);
score := score + 10 * Level;
DrawTarget;
Exec:=False;
Exit;
end;
LastSnake.Left:=NewLeft;
LastSnake.Top:=NewTop;
for i:=0 to Body_pieces do
if i < Body_pieces then
Parts<i> :=Parts[i + 1]
else
Parts<i> :=LastSnake;
Exec:=False;
end; { TmrSnakeTimer }
{----------------------------------------------------------}
procedure TfrmGame.read_inifile;
var
ConfigIni : TMyIniFile;
config_filename : string;
begin
config_filename := ChangeFileExt( Application.ExeName, '.ini' );
if FileExists( config_filename ) then
begin
ConfigIni := TMyIniFile.Create( config_filename );
try
Level := ConfigIni.ReadInteger( 'Options', 'Level', level );
TimeToWaitBeforeMovingTarget := ConfigIni.ReadInteger( 'Options', 'When to Move Target',
DefaultTimeToWaitBeforeMovingTarget );
want_sounds := ConfigIni.MyReadBool( 'Options', 'Want Sounds', want_sounds );
want_borders := ConfigIni.MyReadBool( 'Options', 'Want Borders', want_borders );
Always_on_top := ConfigIni.MyReadBool( 'Options', 'Always On Top', always_on_top );
finally
ConfigIni.free;
end;
end;
end; { read_inifile }
{----------------------------------------------------------}
procedure TfrmGame.save_inifile;
var
ConfigIni : TMyIniFile;
config_filename : string;
begin
config_filename := ChangeFileExt( Application.ExeName, '.ini' );
ConfigIni := TMyIniFile.Create( config_filename );
try
ConfigIni.WriteInteger( 'Options', 'Level', level );
ConfigIni.WriteInteger( 'Options', 'When to Move Target', TimeToWaitBeforeMovingTarget );
ConfigIni.MyWriteBool( 'Options', 'Want Sounds', want_sounds );
ConfigIni.MyWriteBool( 'Options', 'Want Borders', want_borders );
ConfigIni.MyWriteBool( 'Options', 'Always On Top', always_on_top );
ConfigIni.UpdateFile;
finally
ConfigIni.free;
end;
end; { save_inifile }
{----------------------------------------------------------}
procedure TfrmGame.FormCreate(Sender: TObject);
begin
Randomize;
Body_pieces:=0;
TimeToWaitBeforeMovingTarget :=
DefaultTimeToWaitBeforeMovingTarget;
game_over := true;
game_paused := false;
playing := false;
score := 0;
PutStatus(Caption,1);
Level:=1; // default level
want_sounds := true; // default is sound on.
want_borders := true;
always_on_top := false;
read_inifile;
show_panel1;
TmrSnake.Interval:=Trunc(500 / Level);
mnuSettings.items[ Level - 1 ].checked := true;
if TimeToWaitBeforeMovingTarget = 0 then
When_to_move_target.items[ 0 ].checked := true
else
When_to_move_target.items[
(TimeToWaitBeforeMovingTarget - TimeToWaitBase) div 20 ].checked := true;
always_on_top := not always_on_top;
mnuAlwaysClick(nil); // this call toggles always on top.
SetSoundMenu;
SetBordersMenu;
// set shortcuts for level menu ... ctrl-1 to ctrl-6
VeryEasy1.ShortCut := ShortCut(Word('1'), [ssCtrl]);
Easy1.ShortCut := ShortCut(Word('2'), [ssCtrl]);
Medium1.ShortCut := ShortCut(Word('3'), [ssCtrl]);
Advanced1.ShortCut := ShortCut(Word('4'), [ssCtrl]);
Expert1.ShortCut := ShortCut(Word('5'), [ssCtrl]);
Professional1.ShortCut := ShortCut(Word('6'), [ssCtrl]);
end; { FormCreate }
{----------------------------------------------------------}
procedure TfrmGame.mnuAlwaysClick(Sender: TObject);
var
Flgs:HWND;
begin
always_on_top := not always_on_top;
mnuAlways.Checked:= always_on_top;
if always_on_top then
Flgs:=HWND_TOPMOST
else
Flgs:=HWND_NOTOPMOST;
SetWindowPos(Handle,Flgs,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
end; { mnuAlwaysClick }
{----------------------------------------------------------}
procedure TfrmGame.mnuAboutClick(Sender: TObject);
var
game_in_progress : Boolean;
begin
game_in_progress := (not game_paused) and playing;
if playing then
mnuPauseClick( nil );
mnuPauseClick( nil );
MessageBox(Handle,'Snake game, coded by //hIDRA_5.' + #13 +
'with minor mods by PEW','Snake game',
MB_ICONINFORMATION);
if game_in_progress then
mnuContinueClick( nil );
end; { mnuAboutClick }
{----------------------------------------------------------}
procedure TfrmGame.mnuPauseClick(Sender: TObject);
begin
TmrSnake.Enabled:=False;
game_paused := true;
show_panel1;
end; { mnuPauseClick }
{----------------------------------------------------------}
procedure TfrmGame.mnuContinueClick(Sender: TObject);
begin
game_paused := false;
show_panel1;
TmrSnake.Enabled:=True;
end; { mnuContinueClick }
{----------------------------------------------------------}
procedure TfrmGame.mnuGameClick(Sender: TObject);
begin
mnuPause.Enabled:=TmrSnake.Enabled and Playing;
mnuContinue.Enabled:=not mnuPause.Enabled and Playing;
mnuFinish.Enabled:=Playing;
end; { mnuGameClick }
{----------------------------------------------------------}
procedure TfrmGame.DrawTarget;
{..........................................................}
function ValidPoint(X,Y: Integer):Boolean;
var
i:Integer;
begin
Result:=True;
for i:=0 to Body_pieces do
if (Parts<i> .Left = X) and
(Parts<i> .Top = Y) then
begin
Result:=False;
Break;
end;
end; { ValidPoint }
{..........................................................}
var
X,Y,OldX,OldY:Integer;
begin
PntTarget.Visible:=False;
// reset the counter to move the target.
CountToWaitBeforeMovingTarget := 0;
OldX:=PntTarget.Left;
OldY:=PntTarget.Top;
repeat
begin
X:=Random(MAX_X);
Y:=Random(MAX_Y);
end;
until ValidPoint(X*W,Y*H) and ((OldX <> X) or (OldY <> Y));
PntTarget.Left:=X * W;
PntTarget.Top:=Y * H;
PntTarget.Visible:=True;
end; { DrawTarget }
{----------------------------------------------------------}
procedure TfrmGame.mnuNewClick(Sender: TObject);
var
j:Integer;
begin
TmrSnake.Enabled:=False;
CountToWaitBeforeMovingTarget := 0;
if Playing then
mnuFinishClick(Self);
if Body_pieces > 0 then
for j:=0 to Body_pieces do
FreeAndNil(Parts[j]);
Body_pieces := starting_body_pieces;
cDir:=sdRight;
for j:=0 to Body_pieces do
begin
Parts[j]:=TSpeedButton.Create(Self);
Parts[j].Parent:=PntGame;
Parts[j].SetBounds(j * W,0,W,H);
Parts[j].Enabled:=False;
Parts[j].Visible:=True;
end;
DrawTarget;
Exec:=False;
game_over := false;
game_paused := false;
Playing:=True;
score := 0;
show_panel1;
TmrSnake.Enabled:=True;
end; { mnuNewClick }
{----------------------------------------------------------}
procedure TfrmGame.mnuFinishClick(Sender: TObject);
var
i:Integer;
begin
TmrSnake.Enabled:=False;
game_over := true;
Playing:=False;
PntTarget.Visible:=False;
Exec:=False;
for i:=0 to Body_pieces do
FreeAndNil(Parts<i> );
end; { mnuFinishClick }
{----------------------------------------------------------}
function TfrmGame.NewPointIsValid(X, Y: Integer):Boolean;
var
R,R1:Boolean;
rank : integer;
begin
R:=(X >= 0) and (X < PntGame.Width) and
(Y >= 0) and (Y < PntGame.Height);
R1:=BobyInBody(X,Y);
if not R or R1 then
begin
TmrSnake.Enabled:=False;
// 'Game Over' sounds nicer than 'You lose', don't you think?
if not R then
ShowMessage( 'The Snake hit one of the walls.' + #13 +
'Game Over' )
else
ShowMessage( 'The Snake hit itself.' + #13 +
'Game Over' );
mnuFinishClick(Self);
frmHiScTab := TfrmHiScTab.create( nil );
try
frmHiScTab.AddScore( level, score, rank );
if rank = 0 then
showmessage( 'Your score was: ' + inttostr(score) + #13 +
'I''m sorry, you didn''t make the High Score Table.' )
else
showmessage( 'That score ranked #' + inttostr( rank ));
frmHiScTab.ShowModal;
finally
frmHisctab.release;
end;
Result:=False;
show_panel1;
end
else
Result:=True;
end; { NewPointIsValid }
{----------------------------------------------------------}
function TfrmGame.BobyInBody(X, Y: Integer): Boolean;
var
j:Integer;
begin
Result:=False;
for j:=0 to Body_pieces do
if (Parts[j].Left = X) and (Parts[j].Top = Y) then
begin
Result:=True;
Break;
end;
end; { BobyInBody }
{----------------------------------------------------------}
procedure TfrmGame.SetAnyLevelClick(Sender: TObject);
var
game_in_progress : Boolean;
begin
game_in_progress := (not game_paused) and playing;
if playing then
mnuPauseClick( nil );
// unchecked the current level
mnuSettings.items[ Level - 1 ].checked := false;
// set the new level
Level := tMenuItem(Sender).MenuIndex + 1;
// check the new level
tMenuItem(Sender).checked := true;
TmrSnake.Interval:=Trunc(500 / Level);
// redraw the panel because the level has changed
show_panel1;
if game_in_progress then
mnuContinueClick( nil );
end; { SetAnyLevelClick }
{----------------------------------------------------------}
procedure TfrmGame.FormClose(Sender: TObject; var Action: TCloseAction);
begin
save_inifile;
Action := caFree;
end; { FormClose }
{----------------------------------------------------------}
procedure TfrmGame.SetAnyTimeToWait(Sender: TObject);
var
game_in_progress : Boolean;
begin
game_in_progress := (not game_paused) and playing;
if playing then
mnuPauseClick( nil );
// uncheck it
if TimeToWaitBeforeMovingTarget = 0 then
When_to_move_target.items[ 0 ].checked := false
else
When_to_move_target.items[
(TimeToWaitBeforeMovingTarget - TimeToWaitBase) div 20 ].checked := false;
// set the interval
if tmenuitem(sender).MenuIndex = 0 then
TimeToWaitBeforeMovingTarget := 0
else
TimeToWaitBeforeMovingTarget := TimeToWaitBase + tmenuitem(sender).MenuIndex * 20;
// checked the new one.
tmenuitem(sender).checked := true;
show_panel1;
if game_in_progress then
mnuContinueClick( nil );
end; { SetAnyTimeToWait }
{----------------------------------------------------------}
procedure TfrmGame.ViewHighScores1Click(Sender: TObject);
var
game_in_progress : boolean;
begin
game_in_progress := (not game_paused) and playing;
if playing then
mnuPauseClick( nil );
frmHiScTab := TfrmHiScTab.create( nil );
try
frmHiScTab.display_table( 0 );
frmHiScTab.ShowModal;
finally
frmHisctab.release;
end;
if game_in_progress then
mnuContinueClick( nil );
end; { ViewHighScores1Click }
{----------------------------------------------------------}
procedure TfrmGame.HowtoPlay1Click(Sender: TObject);
var
game_in_progress : boolean;
begin
game_in_progress := (not game_paused) and playing;
if playing then
mnuPauseClick( nil );
showmessage( 'How to Play' + #13 +
'===========' + #13 +
'The rules are very simple:' + #13 +
'* Use the cursor keys to move the snake around the screen to eat the green target. When one target is eaten, another will appear.' + #13 +
'* Each time the snake eats a target it grows one square longer and 10 x Level will be added to your score.' + #13 +
'* If the snake hits itself or a wall (with borders on) then the game ends.' + #13 +
'* The borders are toggled (on/off) with ctrl-B. When borders are Off, you can move through the walls. When borders are On, hitting a wall ends the game.' + #13 +
'* The target moves at intervals set in the "Options / When to move target..." menu.' + #13 +
'* There are 6 levels; set with ctrl-1 (Very Easy) thru ctrl-6 (Professional).' + #13 +
'* Sound is switched toggled (on/off) with ctrl-S.' + #13 +
'* The game is paused with F3 and continued with F4.' + #13 +
'* F2 finishes the game (ends it), without exiting.' + #13 +
'* The top 10 scores and recorded in the Hall of Fame. Press F5 to view it.' + #13 +
'* Alt-F4 Exits the Game.' );
if game_in_progress then
mnuContinueClick( nil );
end; { HowtoPlay1Click }
{----------------------------------------------------------}
procedure TfrmGame.SetSoundMenu;
begin
Sound1.Checked := want_sounds;
if want_sounds then
Sound1.caption := 'Sound (is on)'
else
Sound1.caption := 'Sound (is off)';
end; { SetSoundMenu }
{----------------------------------------------------------}
procedure TfrmGame.Sound1Click(Sender: TObject);
var
game_in_progress : Boolean;
begin
game_in_progress := (not game_paused) and playing;
if playing then
mnuPauseClick( nil );
want_sounds := not want_sounds;
SetSoundMenu;
if game_in_progress then
mnuContinueClick( nil );
end; { Sound1Click }
{----------------------------------------------------------}
procedure TfrmGame.SetBordersMenu;
begin
Borders1.Checked := want_borders;
if want_borders then
Borders1.caption := '&Borders (are on)'
else
Borders1.caption := '&Borders (are off)';
end; { SetBordersMenu }
{----------------------------------------------------------}
procedure TfrmGame.Borders1Click(Sender: TObject);
var
game_in_progress : Boolean;
begin
game_in_progress := (not game_paused) and playing;
if playing then
mnuPauseClick( nil );
want_borders := not want_borders;
SetBordersMenu;
show_panel1;
if game_in_progress then
mnuContinueClick( nil );
end; { Borders1Click }
{----------------------------------------------------------}
]]>