:
Name ;
Caption ;
Left, Top - X Y
Width, Height - X Y
Color ;
:
OnCreate :
OnClose - :
OnPaint .
:
Close ;
Hide ;
Show .
TMainMenu . TMainMenu , . () , .
:
1) TMainMenu ,
2) Items ,
3) .
TStatusBar .
TImage . BMP, ICO, WMF.
ImageList , , 0. TimageList:
Height - ;
Wight ;
AllocBy , ;
Count . .
TDialog OpenDialog SaveDialog, . OpenDialog , SaveDialog ( ...).
2. .
. . 1
 |
-
 |
|
 | |||||
 | |||||
 |
1. -
 |
 |
 | |||
 | |||
 | |||
-
 | |||
 |
|
1. - ()
|
|
|
, , .
, .
.
, , .
 |
2 - -
m,w,r.
3. .
Delphi , . . Delphi ( dpr) ( pas). Object Pascal.
, Object Pascal . Delphi.
. Delphi, , .
Uses , , .
, , .
1. .
| Unit1.pas | 485 b | |
| Unit2.pas | 2 Kb | |
| Unit3.pas | 1Kb | |
| Unit1.dfm | 485 Kb | |
| Unit2.dfm | 2Kb | |
| Unit3.dfm | 1Kb | |
| Project1.dpr | 1 Kb | |
| Project1.res | 20 Kb |
dpr. Delphi pas, dfm dcu : pas , dfm , dcu- . dcu , exe.
. Delphi .
:
x,y,:integer ;
c:integer ;
i,j:integer ;
sc,nl:integer .
:
TForm1.
.
procedure Init(m,w,r:boolean) - ,
procedure CreateSpheres(x,y,c:integer) - x,y c
procedure NewSpheres(quantity:integer) -
|
|
|
procedure ClickSpheres(Sender: TObject) -
procedure Wave(x1,y1,x2,y2:integer) -
procedure Way(x1,y1,x2,y2:integer) - (x1, y1) (x2, y2)
procedure Move(x1,y1,x2,y2:integer) -
procedure Pause(milliseconds:integer) -
procedure DestroySpheres(x,y,k,i,j:integer) - k , i, j
procedure Data(sc,nl:integer) -
procedure DestroyLines -
procedure Restart -
:
function EmptyPos(Pole:Desk):integer - ( )
function ExitMap(x,y:integer):Boolean -
function FindLine(x,y,i,j:integer):integer - x,y
function FindSphere(x,y:integer):TImage - Image'a x,y
procedure FormCreate(Sender: TObject); -
.
4.
: , , . , , , .
:
1) Windows XP\Vista.
2) 64
3) 1 .
.exe , ( .exe ).
( .1) .
:
1. ALT+X, .( .2)
2. ( .3) .
:
1. , , .
2. , .
3. , , .
( 4.).
( .5).
:
1. , .
Windows Borland Delphi.
: , , , , . , .
.
1. .. Delphi. . , , 2005.
2. Delphi.
3. , . Delphi. / . . - : , 2005.
4. Delphi 7. / . , . , . , . . - : , 2008.
.
()
|
|
|
1. Unit1. Pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Buttons, Menus, ComCtrls;
type Desk=array [0..8,0..8] of integer;
type
TForm1 = class(TForm)
Area: TImage;
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
StatusBar1: TStatusBar;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
N11: TMenuItem;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
N7: TMenuItem;
procedure Init(m,w,r:boolean); //,
procedure CreateSpheres(x,y,c:integer); // x,y c
procedure NewSpheres(quantity:integer); //
procedure ClickSpheres(Sender: TObject); //
procedure Wave(x1,y1,x2,y2:integer); //
procedure Way(x1,y1,x2,y2:integer); // (x1, y1) (x2, y2)
procedure Move(x1,y1,x2,y2:integer); //
procedure Pause(milliseconds:integer); //
procedure DestroySpheres(x,y,k,i,j:integer);// k , i, j
procedure Data(sc,nl:integer); //
procedure DestroyLines; //
procedure Restart; //
function EmptyPos(Pole:Desk):integer; // ( )
function ExitMap(x,y:integer):boolean; //
function FindLine(x,y,i,j:integer):integer; // x,y
function FindSphere(x,y:integer):TImage; // Image'a x,y
procedure FormCreate(Sender: TObject);
procedure AreaMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure N6Click(Sender: TObject);
procedure N3Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N5Click(Sender: TObject);
procedure N11Click(Sender: TObject);
procedure N7Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Road,WaveMap,Map:Desk;
clisp:boolean;
xsp,ysp:integer;
numlines,score:integer;
RoadFlag,DestroyFlag:boolean;
implementation
uses Unit2, Unit3;
{$R *.dfm}
procedure TForm1.Init(m,w,r:boolean);
var
x,y:integer;
begin
for y:=0 to 8 do begin
for x:=0 to 8 do begin
if m=true then Map[x,y]:=0;
if w=true then WaveMap[x,y]:=0;
if r=true then Road[x,y]:=0;
end;
end;
end;
procedure TForm1.CreateSpheres(x,y,c:integer);
begin
with TImage.Create(self) do begin
Autosize:=true; TransParent:=true;
Left:=x; Top:=y;
Picture.LoadFromFile('Bitmaps\'+inttostr(c)+'.bmp');
parent:=form1;
Onclick:=ClickSpheres;
end;
end;
procedure TForm1.NewSpheres(quantity:integer);
var
i,c,x,y:integer;
label Return;
begin
Randomize;
if EmptyPos(Map)>3 then begin
for i:=1 to Quantity do begin
Return:
x:=random(9);
y:=random(9);
c:=random(7)+1;
if Map[x,y]=0 then begin
Map[x,y]:=c;
CreateSpheres(x*30,y*30,c);
end else goto Return;
end;
end else begin
showmessage(' .');
Form3.Show;
Restart;
NewSpheres(3);
end;
end;
function TForm1.ExitMap(x,y:integer):boolean;
begin
ExitMap:=false;
if (x>=0) and (x<=8) and (y>=0) and (y<=8) then ExitMap:=true;
end;
procedure TForm1.Wave(x1,y1,x2,y2:integer);
var
x,y,k:integer;
flag:boolean;
begin
flag:=true;
for y:=0 to 8 do begin
|
|
|
for x:=0 to 8 do begin
if Map[x,y]>0 then WaveMap[x,y]:=-1 else WaveMap[x,y]:=0;
end;
end;
k:=1; WaveMap[x1,y1]:=k;
while flag do begin
flag:=false;
for y:=0 to 8 do begin
for x:=0 to 8 do begin
if WaveMap[x,y]=k then begin
if (WaveMap[x-1,y]=0) and (Exitmap(x-1,y)=true) then begin
WaveMap[x-1,y]:=k+1;
flag:=true;
end;
if (WaveMap[x+1,y]=0) and (Exitmap(x+1,y)=true) then begin
WaveMap[x+1,y]:=k+1;
flag:=true;
end;
if (WaveMap[x,y-1]=0) and (Exitmap(x,y-1)=true) then begin
WaveMap[x,y-1]:=k+1;
flag:=true;
end;
if (WaveMap[x,y+1]=0) and (Exitmap(x,y+1)=true) then begin
WaveMap[x,y+1]:=k+1;
flag:=true;
end;
end;
end;
end;
if WaveMap[x2,y2]>0 then flag:=false else k:=k+1;
end;
end;
procedure TForm1.Way(x1,y1,x2,y2:integer);
var
k:integer;
begin
k:=WaveMap[x2,y2];
Road[x2,y2]:=k-WaveMap[x1,y1]+1;
if (ExitMap(x2-1,y2)=true) and (WaveMap[x2-1,y2]=k-1) then Way(x1,y1,x2-1,y2) else
if (ExitMap(x2+1,y2)=true) and (WaveMap[x2+1,y2]=k-1) then Way(x1,y1,x2+1,y2) else
if (ExitMap(x2,y2-1)=true) and (WaveMap[x2,y2-1]=k-1) then Way(x1,y1,x2,y2-1) else
if (ExitMap(x2,y2+1)=true) and (WaveMap[x2,y2+1]=k-1) then Way(x1,y1,x2,y2+1);
end;
function TForm1.FindSphere(x,y:integer):TImage;
var
i:integer;
begin
for i:=0 to ComponentCount-1 do begin
if (Components[i] is TImage) and (Timage(Components[i]).Name<>'Area') and (Timage(Components[i]).Left=x) and (Timage(Components[i]).top=y) then begin
Result:=Timage(Components[i]);
exit;
end;
end;
end;
procedure TForm1.Move(x1,y1,x2,y2:integer);
var
Image:Timage;
x,y,i:integer;
begin
RoadFlag:=false;
init(false,true,true);
Image:=FindSphere(x1*30,y1*30);
Wave(x1,y1,x2,y2);
if WaveMap[x2,y2]>0 then begin
RoadFlag:=true;
Way(x1,y1,x2,y2);
x:=x1;
y:=y1;
repeat
Pause(50);
if Road[x-1,y]-Road[x,y]=1 then begin
x:=x-1;
end else
if Road[x+1,y]-Road[x,y]=1 then begin
x:=x+1;
end else
if Road[x,y-1]-Road[x,y]=1 then begin
y:=y-1;
end else
if Road[x,y+1]-Road[x,y]=1 then begin
y:=y+1;
end;
Image.Left:=x*30;
Image.Top:=y*30;
until (x=x2) and (y=y2);
Map[x2,y2]:=Map[x1,y1];
Map[x1,y1]:=0;
end;
end;
procedure TForm1.ClickSpheres(Sender: TObject);
begin
clisp:=true;
xsp:=(sender as TImage).Left div 30;
ysp:=(sender as TImage).top div 30;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
score:=0;
numlines:=0;
Init(true,true,true);
NewSpheres(3);
end;
procedure TForm1.Pause(milliseconds:integer);
begin
application.ProcessMessages;
sleep(milliseconds);
end;
procedure TForm1.DestroySpheres(x,y,k,i,j:integer);
var
n,dx,dy:integer;
image:TImage;
begin
n:=0; dx:=x; dy:=y;
while n<>k do begin
image:=FindSphere(dx*30,dy*30); image.Destroy;
application.ProcessMessages;
Map[dx,dy]:=0;
n:=n+1; dx:=dx+i; dy:=dy+j;
end;
Data(k,1);
DestroyFlag:=true;
end;
function TForm1.FindLine(x,y,i,j:integer):integer;
var
dx,dy,k:integer;
begin
dx:=x; dy:=y; k:=0;
while Map[x,y]=Map[dx,dy] do begin
if ExitMap(dx,dy)=true then begin
dx:=dx+i;
dy:=dy+j;
k:=k+1;
end else break;
end;
result:=k;
end;
procedure TForm1.DestroyLines;
var
x,y,k,i,j:integer;
begin
DestroyFlag:=false;
for y:=0 to 8 do begin
for x:=0 to 8 do begin
if Map[x,y]<>0 then begin
if FindLine(x,y,1,0)>3 then DestroySpheres(x,y,FindLine(x,y,1,0),1,0) else
if FindLine(x,y,1,1)>3 then DestroySpheres(x,y,FindLine(x,y,1,1),1,1)else
if FindLine(x,y,0,1)>3 then DestroySpheres(x,y,FindLine(x,y,0,1),0,1) else
if FindLine(x,y,-1,1)>3 then DestroySpheres(x,y,FindLine(x,y,-1,1),-1,1);
end;
end;
end;
end;
function TForm1.EmptyPos(Pole:Desk):integer;
var
x,y,e:integer;
begin
e:=0;
for y:=0 to 8 do begin
for x:=0 to 8 do begin
if Pole[x,y]=0 then e:=e+1;
end;
end;
result:=e;
end;
procedure TForm1.Data(sc,nl:integer);
begin
numlines:=numlines+nl;
score:=score+sc;
Statusbar1.Panels[0].Text:=' : '+inttostr(numlines);
Statusbar1.Panels[1].Text:=': '+inttostr(score);
end;
procedure TForm1.AreaMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if clisp=true then begin
clisp:=false;
Move(xsp,ysp,x div 30,y div 30);
if RoadFlag=true then begin
Pause(100);
DestroyLines;
Pause(150);
if DestroyFlag=false then begin
NewSpheres(3);
DestroyLines;
end;
end;
RoadFlag:=false;
end;
|
|
|
end;
procedure TForm1.N6Click(Sender: TObject);
begin
form1.Close;
end;
procedure TForm1.Restart;
var
i:integer;
label Return;
begin
init(true,true,true);
score:=0;
numlines:=0;
Return:
for i:=0 to ComponentCount-1 do begin
if (Components[i] is TImage) and (Timage(Components[i]).Name<>'Area') then begin
Timage(Components[i]).Destroy;
goto Return;
end;
end;
Statusbar1.Panels[0].Text:=' : 0';
Statusbar1.Panels[1].Text:=': 0';
end;
procedure TForm1.N3Click(Sender: TObject);
begin
Restart;
NewSpheres(3);
end;
procedure TForm1.N4Click(Sender: TObject);
var
F:File;
begin
if SaveDialog1.Execute then begin
//if FileExists(SaveDialog1.FileName) then
// if Application.MessageBox(' . ?','',mb_YesNo) <> 6 then Exit;
AssignFile(f,SaveDialog1.FileName+'.sav');
{$I-} ReWrite(f,1); {$I+}
//ReWrite(f);
//WriteLn(F,);
end;
if IOResult <> 0 then begin
Application.MessageBox(' !','',mb_ok);
Exit;
end;
end;
procedure TForm1.N5Click(Sender: TObject);
var
f:File;
s:string;
begin
S:=OpenDialog1.FileName;
AssignFile(f,s);
{$I-} Reset(f,1); {$I+}
if IOResult <> 0 then begin
Application.MessageBox(' !','',mb_ok);
Exit;
end;
end;
procedure TForm1.N11Click(Sender: TObject);
begin
showmessage(' : );
end;
procedure TForm1.N7Click(Sender: TObject);
begin
Form2.Show;
end;
end.
2. Unit2. Pas
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, jpeg, ExtCtrls;
type
TForm2 = class(TForm)
Image1: TImage;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses Unit1, Unit3;
{$R *.dfm}
procedure TForm2.Button1Click(Sender: TObject);
begin
close;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
if application.Messagebox (' ?','information',mb_yesno)= id_yes then
begin
Label1.Caption:='---';
Label2.Caption:='---';
Label3.Caption:='---';
Label4.Caption:='---';
Label5.Caption:='---';
Label6.Caption:='---';
end;
end;
end.
3. Unit3. Pas
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm3 = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form3: TForm3;
implementation
uses Unit1, Unit2;
{$R *.dfm}
procedure TForm3.Button1Click(Sender: TObject);
begin
if strtoint(Form2.Label4.caption)> score then
begin
Form2.label5.Caption:=inttostr(score);
Form2.Label2.Caption:=Edit1.text;
end;
if strtoint (Form2.Label5.Caption)>score then
begin Form2.Label6.Caption:=inttostr(score);
Form2.Label3.Caption:=Form3.Edit1.Text;
end;
Form2.Label1.Caption:=Form3.Edit1.Text;
Form2.Label4.Caption:=inttostr(score);
close;
end;
procedure TForm3.Button2Click(Sender: TObject);
begin
close;
end;
end.
 |
()
1. .
2
3. .
4. 
.
