Модуль управления интерфейсом программы:
unit MainUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,PaintingGraph, ComCtrls, ToolWin, ImgList, Menus,
ActnList, ExtCtrls;
const
crMyCursor = 5;
type
TForm1 = class(TForm)
SaveDialog1: TSaveDialog;
OpenDialog1: TOpenDialog;
ImageList1: TImageList;
ImageList2: TImageList;
LoadMenu: TPopupMenu;
ControlBar1: TControlBar;
ToolBar3: TToolBar;
OpenButton: TToolButton;
SaveButton: TToolButton;
ToolButton15: TToolButton;
ClearButton: TToolButton;
UpdateButton: TToolButton;
HelpButton: TToolButton;
ToolButton26: TToolButton;
RemovePointButton: TToolButton;
ToolButton28: TToolButton;
ToolButton32: TToolButton;
SettingButton: TToolButton;
ControlBar2: TControlBar;
AlgoritmToolBar: TToolBar;
KommiTool: TToolButton;
ToolButton: TToolButton;
NotFarButton: TToolButton;
MinLengthButton: TToolButton;
ToolButton5: TToolButton;
MovePointButton: TToolButton;
ActionList1: TActionList;
AShowGrig: TAction;
ASnapToGrid: TAction;
ASave: TAction;
ALoad: TAction;
ADelete: TAction;
GridToolBar: TToolBar;
Clock: TLabel;
Timer1: TTimer;
ShowGridButton: TToolButton;
AutoLengthButton: TToolButton;
SnapToGridButton: TToolButton;
PaintBox1: TPaintBox;
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormPaint(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure ClearButtonClick(Sender: TObject);
procedure KommiToolButtonClick(Sender: TObject);
procedure PaintingToolButtonClick(Sender: TObject);
procedure SnapToGridButtonClick(Sender: TObject);
procedure HelpButtonClick(Sender: TObject);
procedure AutoLengthButtonClick(Sender: TObject);
procedure SettingButtonClick(Sender: TObject);
procedure NotFarButtonClick(Sender: TObject);
procedure MinLengthButtonClick(Sender: TObject);
procedure MovePointButtonClick(Sender: TObject);
procedure RemovePointButtonClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure ALoadExecute(Sender: TObject);
procedure AShowGrigExecute(Sender: TObject);
procedure ASaveExecute(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure UpdateButtonClick(Sender: TObject);
procedure EilerButtonClick(Sender: TObject);
procedure ClockClick(Sender: TObject);
private
procedure MyPopupHandler(Sender: TObject);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses IO,Data,Commercial,DrawingObject,Setting,NotFar,MinLength, Eiler,
SplashScreen;
{$R *.DFM}
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button=mbLeft then begin
MyIO.FormMouseDown(X, Y);
if (MyIO.State=msMove)then
if MyIO.FirstPointActive then
Cursor:= crMyCursor
else begin
Repaint;
Cursor:= crDefault;
end;
end
else
MyIO.MakeLine(X, Y);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.Cursors[crMyCursor]:= LoadCursor(HInstance, 'Shar');
MyIO:=TIO.Create(PaintBox1.Canvas);
MyData:=TData.Create;
MyDraw:=TDrawingObject.Create(PaintBox1.Canvas);
SaveDialog1.InitialDir:=ExtractFilePath(Application.ExeName)+'Grafs';
OpenDialog1.InitialDir:=ExtractFilePath(Application.ExeName)+'Grafs';
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
MyIO.DrawLine(x,y);
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
PaintBox1Paint(Sender);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key=vk_Escape) then
begin
MyData.Remove(MyData.Dimension);
MyDraw.Remove(MyData.Dimension);
Repaint;
end;
end;
procedure TForm1.MyPopupHandler(Sender: TObject);
var s:string;
begin
with Sender as TMenuItem do begin
s:=Caption;
MyData.Load(s);
System.Delete(s,length(s)-4,5);
MyDraw.Load(s+'.pos');
end;
Repaint;
end;
procedure TForm1.ClearButtonClick(Sender: TObject);
begin
MyData.Clear;
MyDraw.Clear;
Repaint;
end;
procedure TForm1.KommiToolButtonClick(Sender: TObject);
begin
If MyData.Dimension<2 then Exit;
MyCommercial:=TCommercial.Create;
MyCommercial.Make;
MyCommercial.Free;
end;
procedure TForm1.EilerButtonClick(Sender: TObject);
begin
If MyData.Dimension<2 then Exit;
EilerC:=TEiler.Create;
EilerC.Make;
EilerC.Free;
MyIO.DrawAll;
RePaint;
end;
procedure TForm1.PaintingToolButtonClick(Sender: TObject);
begin
If MyData.Dimension<2 then Exit;
MyPaint:=TPaintingGraphClass.Create;
MyPaint.Make;
RePaint;
MyPaint.Free;
end;
procedure TForm1.SnapToGridButtonClick(Sender: TObject);
begin
MyIO.FSnapToGrid:=SnapToGridButton.Down;
end;
procedure TForm1.HelpButtonClick(Sender: TObject);
begin
Application.HelpContext(10);
end;
procedure TForm1.AutoLengthButtonClick(Sender: TObject);
begin
MyIo.AutoLength:=AutoLengthButton.Down;
end;
procedure TForm1.SettingButtonClick(Sender: TObject);
begin
SettingForm.Show;
end;
procedure TForm1.NotFarButtonClick(Sender: TObject);
begin
If MyData.Dimension<2 then Exit;
MyNotFar:=TNotFar.Create;
MyNotFar.Make;
MyNotFar.Free;
end;
procedure TForm1.MinLengthButtonClick(Sender: TObject);
begin
If MyData.Dimension<2 then Exit;
MyMinLength:=TMinLength.Create;
MyMinLength.Make;
MyMinLength.Free;
end;
procedure TForm1.MovePointButtonClick(Sender: TObject);
begin
if MovePointButton.Down then MyIO.State:=msMove else
MyIO.State:=msNewPoint;
if MovePointButton.Down=false then
Cursor:= crDefault;
end;
procedure TForm1.RemovePointButtonClick(Sender: TObject);
begin
if ReMovePointButton.Down then MyIO.State:=msDelete else
MyIO.State:=msNewPoint;
Repaint;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Clock.Caption:=TimeToStr(Time);
end;
procedure TForm1.ALoadExecute(Sender: TObject);
var s:string;
begin
if OpenDialog1.Execute then
try
s:=OpenDialog1.Filename;
MyData.Load(s);
Delete(s,length(s)-4,5);
MyDraw.Load(s+'.pos');
finally
end;
Repaint;
end;
procedure TForm1.AShowGrigExecute(Sender: TObject);
begin
MyIO.FDrawGrid:=ShowGridButton.Down;
Repaint;
end;
procedure TForm1.ASaveExecute(Sender: TObject);
var s:string;
m:TMenuItem;
begin
if SaveDialog1.Execute then
try
s:=SaveDialog1.Filename;
MyData.Save(s);
Delete(s,length(s)-4,5);
MyDraw.Save(s+'.Pos')
finally
end;
m:=TMenuItem.Create(Self);
m.Caption:=SaveDialog1.Filename;
m.OnClick:= MyPopUpHandler;
LoadMenu.Items.Add(m);
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
MyIO.DrawCoordGrid(16,16,ClientWidth-30,ClientHeight-140);
MyIO.DrawAll;
end;
procedure TForm1.UpdateButtonClick(Sender: TObject);
begin
MyDraw.SetAllUnActive;
MyIO.DrawAll;
MyIO.FirstPointActive:=false;
end;
procedure TForm1.ClockClick(Sender: TObject);
begin
Splash.Show;
end;
end.
Модуль управления окном настроек:
unit Setting;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, Spin,IO,MainUnit, ExtCtrls;
type
TSettingForm = class(TForm)
GridGroupBox: TGroupBox;
Label1: TLabel;
Label2: TLabel;
ColorDialog1: TColorDialog;
Label3: TLabel;
OkBitBtn: TBitBtn;
CancelBitBtn: TBitBtn;
ColorButton: TPanel;
Label4: TLabel;
Label5: TLabel;
CoordCheckBox: TCheckBox;
GridCheckBox: TCheckBox;
StepSpinEdit: TSpinEdit;
MashtabSpinEdit: TSpinEdit;
Colors: TGroupBox;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
procedure ColorButtonClick(Sender: TObject);
procedure OkBitBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CoordCheckBoxClick(Sender: TObject);
procedure GridCheckBoxClick(Sender: TObject);
procedure CancelBitBtnClick(Sender: TObject);
procedure Panel2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
SettingForm: TSettingForm;
implementation
{$R *.DFM}
procedure TSettingForm.ColorButtonClick(Sender: TObject);
begin
if ColorDialog1.Execute then begin
ColorButton.Color:=ColorDialog1.Color;
MyIO.GridColor:=Color;
Form1.Repaint;
end;
end;
procedure TSettingForm.OkBitBtnClick(Sender: TObject);
begin
MyIO.GridColor:=ColorButton.Color;
MyIO.GrigStep:=StepSpinEdit.Value;
MyIO.Mashtab:=MashtabSpinEdit.Value;
Close;
end;
procedure TSettingForm.FormShow(Sender: TObject);
begin
with MyIO do begin
ColorButton.Color:=MyIO.GridColor;
StepSpinEdit.Value:=MyIO.GrigStep;
MashtabSpinEdit.Value:=MyIO.Mashtab;
CoordCheckBox.Checked:=MyIO.FDrawCoord;
GridCheckBox.Checked:=MyIO.FDrawGrid;
Panel2.Color:=RebroColor;
Panel3.Color:=TextColor;
Panel1.Color:=MovingColor;
end;
end;
procedure TSettingForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
with MyIO do begin
GridColor:=ColorButton.Color;
GrigStep:=StepSpinEdit.Value;
Mashtab:=MashtabSpinEdit.Value;
FDrawCoord:=CoordCheckBox.Checked;
FDrawGrid:=GridCheckBox.Checked;
Form1.ShowGridButton.Down:=GridCheckBox.Checked;
RebroColor:=Panel2.Color;
TextColor:=Panel3.Color;
MovingColor:=Panel1.Color;
end;
Form1.Repaint;
end;
procedure TSettingForm.CoordCheckBoxClick(Sender: TObject);
begin
MyIO.FDrawCoord:=CoordCheckBox.Checked;
//Form1.Repaint;
end;
procedure TSettingForm.GridCheckBoxClick(Sender: TObject);
begin
MyIO.FDrawGrid:=GridCheckBox.Checked;
//Form1.Repaint;
end;
procedure TSettingForm.CancelBitBtnClick(Sender: TObject);
begin
Close;
end;
procedure TSettingForm.Panel2Click(Sender: TObject);
begin
with Sender as TPanel do
if ColorDialog1.Execute then begin
Color:=ColorDialog1.Color;
end;
end;
end.
Вспомогательный модуль потроения графа в окне программы:
unit IO;
interface
uses Data,DrawingObject,Graphics,windows,Math,Controls,Dialogs,SysUtils;
type
MouseState=(msNewPoint,msLining,msMove,msDelete);
TIO=class
private
xt,yt,xs,ys: integer;
// FLining: boolean;
ActivePoint: integer;
MyCanvas: TCanvas;
public
GridColor: TColor;
RebroColor: TColor;
TextColor: TColor;
MovingColor: TColor;
State: MouseState;
FDrawGrid: boolean;
FDrawCoord: boolean;
FSnapToGrid: boolean;
GrigStep: integer;
FirstPoint: integer;
FirstPointActive: boolean;
LastPoint: integer;
AutoLength: boolean;
Mashtab: integer;
procedure MakeLine(X, Y: Integer);
procedure DrawPath(First,Last:integer;Light:boolean=false);
procedure IONewPoint(xPos,yPos:integer);
procedure DrawAll;
procedure FormMouseDown(X, Y: Integer);
procedure Select(FirstPoint,LastPoint:integer);
procedure DrawCoordGrid(x,y,x1,y1:integer);
procedure DrawLine(x1,y1:Integer);
procedure RemovePoint(Num:integer);
constructor Create(Canvas:TCanvas);
end;
var MyIO:TIO;
implementation
procedure TIO.MakeLine(X, Y: Integer);
var i:integer;
V1,V2:TPoint;
begin
i:=MyDraw.FindNumberByXY(X,Y);
if i<>-1 then
if State=msLining then begin
MyData.Rebro(ActivePoint,i);
if AutoLength then begin
V1:=MyDraw.FindByNumber(ActivePoint);
V2:=MyDraw.FindByNumber(i);
MyData.SetRebroLength(ActivePoint,i,Round(
sqrt(sqr(Mashtab*(V1.x-V2.x)/ GrigStep)+
sqr(Mashtab*(V1.y-V2.y)/ GrigStep))));
end;
MyCanvas.MoveTo(xs,ys);
MyCanvas.LineTo(xt,yt);
DrawPath(ActivePoint,i,false);
State:=msNewPoint;
MyDraw.SetUnActive(ActivePoint);
end
else begin
ActivePoint:=i;
State:=msLining;
xs:=MyDraw.FindByNumber(i).x; xt:=xs;
ys:=MyDraw.FindByNumber(i).y; yt:=ys;
MyDraw.SetActive(i);
end;
end;
procedure TIO.DrawLine(x1,y1:Integer);
begin
if State=msLining then
with MyCanvas do
begin
Pen.Width:=2;
Pen.Color:=MovingColor;
Pen.Mode:=pmXor;
Pen.Style:=psSolid;
MoveTo(xs,ys);
LineTo(xt,yt);
MoveTo(xs,ys);
LineTo(x1,y1);
xt:=x1;
yt:=y1;
end;
{if State=msMove then
with MyCanvas do
begin
Pen.Width:=2;
Pen.Color:=MovingColor;
Pen.Mode:=pmXor;
Pen.Style:=psSolid;
MoveTo(xs,ys);
LineTo(xt,yt);
MoveTo(xs,ys);
LineTo(x1,y1);
xt:=x1;
yt:=y1;
end;}
end;
procedure TIO.FormMouseDown(X, Y: Integer);
var Mini,Maxi,i,j,Temp,Te:integer;
b,k:real;
Flag:Boolean;
function StepRound(Num,Step:integer):integer;
begin
if (Num mod Step)>(Step/2)then Result:=Num- Num mod Step+Step
else Result:=(Num div Step)*Step;
end;
begin
Te:=MyDraw.FindNumberByXY(X,Y);
if (Te=-1)and(state<>msMove) then
with MyData,MyDraw do begin
i:=1;
j:=1;
Flag:=false;
repeat
repeat
if (Dimension>0)and(Matrix[i,j]=1) then begin
Mini:=Min(FindByNumber(i).x,FindByNumber(j).x);
Maxi:=Max(FindByNumber(i).x,FindByNumber(j).x);
if Mini<>Maxi then
k:=(FindByNumber(i).y-FindByNumber(j).y)/(FindByNumber(i).x-FindByNumber(j).x)
else k:=0;
b:= FindByNumber(i).y- (k*FindByNumber(i).x);
if (X>=Mini)and(X<Maxi) and
(Y>=(k*X+b-8))and (Y<=(k*X+b+8))
then begin
Flag:=true;
Select(i,j);
Exit;
end;
end;
inc(i);
until(Flag)or(i>Dimension);
inc(j);
i:=1;
until(Flag)or(j>Dimension);
end
else begin
if FirstPointActive then begin
if State=msMove then begin
flag:=true;
MyDraw.move(FirstPoint,x,y);
MyDraw.SetUnActive(FirstPoint);
DrawAll;
FirstPointActive:=False;
end;
LastPoint:=Te
end
else begin
FirstPoint:=Te;
FirstPointActive:=True;
end;
MyDraw.SetActive(Te);
if State=msDelete then
RemovePoint(Te);
Exit;
end;
if not flag then begin
if FSnapToGrid then IONewPoint(StepRound(x,GrigStep),StepRound(y,GrigStep))
else IONewPoint(x,y);end;
end;
procedure TIO.Select(FirstPoint,LastPoint:integer);
var s:string;
begin
with MyData do begin
DrawPath(FirstPoint,LastPoint,true);
S:=InputBox('Ввод','Введите длину ребра ','');
if(s='')or(not(StrToInt(S) in [1..250]))then begin
ShowMessage('Некорректно введена длина');
exit;
end;
{ if Oriented then
if Matrix[FirstPoint,LastPoint]<>0 then
MatrixLength[FirstPoint,LastPoint]:=StrToInt(S)else
MatrixLength[LastPoint,FirstPoint]:=StrToInt(S)
else
begin }
LengthActive:=True;
SetRebroLength(FirstPoint,LastPoint,StrToInt(S));
// end;
DrawPath(FirstPoint,LastPoint,false);
end;
end;
procedure TIO.DrawPath(First,Last:integer;Light:boolean=false);
var s:string;
begin
with MyDraw,MyCanvas do
begin
{!!pmMerge} Pen.Mode:=pmCopy;
Pen.Width:=2;
brush.Style:=bsClear;
Font.Color:=TextColor;
PenPos:=FindByNumber(First);
if Light then begin
Pen.Color:=clYellow;
SetActive(First);
SetActive(Last);
end
else Pen.Color:=RebroColor;
LineTo(FindByNumber(Last).x,
FindByNumber(Last).y);
if (MyData.LengthActive)and
(MyData.MatrixLength[First,Last]<>0) then
begin
s:=IntToStr(MyData.MatrixLength[First,Last]);
TextOut((FindByNumber(Last).x+FindByNumber(First).x)div 2,
(FindByNumber(Last).y+FindByNumber(First).y) div 2-13,s);
end;
DrawSelf(First);
DrawSelf(Last);
end;
end;
procedure TIO.DrawAll;
var i,j:byte;
begin
for i:=1 to MyData.Dimension do
for j:=1 to MyData.Dimension do
if MyData.Matrix[i,j]=1 then DrawPath(i,j,false);
MyDraw.DrawAll;
end;
procedure TIO.IONewPoint(xPos,yPos:integer);
begin
MyData.NewPoint;
MyDraw.NewPoint(xPos,yPos);
MyDraw.DrawAll;
end;
procedure TIO.DrawCoordGrid(x,y,x1,y1:integer);
var i,j,nx,ny,nx1,ny1:integer;
begin
if FDrawGrid then begin
nx:=x div GrigStep;
nx1:=x1 div GrigStep;
ny:=y div GrigStep;
ny1:=y1 div GrigStep;
MyCanvas.Brush.Style:=bsClear;
MyCanvas.Pen.Color:=GridColor;
for i:=1 to nx1-nx do
for j:=1 to ny1-ny do
MyCanvas.Pixels[i*GrigStep,y1-j*GrigStep]:=GridColor;
end;
if FDrawCoord then
with MyCanvas do begin
Pen.Width:=1;
MoveTo(nx+GrigStep,y-5);
LineTo(nx+GrigStep,y1+2);
LineTo(x1-4,y1+2);
{horizontal}
for i:=1 to nx1-nx do begin
MoveTo(nx+i*GrigStep,y1-1);
LineTo(nx+i*GrigStep,y1+5);
TextOut(nx+i*GrigStep-5,y1+8,IntToStr((i-1)*Mashtab));
end; {vertical}
for i:=1 to ny1-ny do begin
MoveTo(x+2,y1-GrigStep*i);
LineTo(x+7,y1-GrigStep*i);
TextOut(x-15,y1-i*GrigStep-GrigStep div 2,IntToStr(i*Mashtab));
end;
end;
end;
constructor TIO.Create(Canvas:TCanvas);
begin
GrigStep:=20;
FSnapToGrid:=true;
GridColor:=clBlack;
RebroColor:=clMaroon;
MovingColor:=clBlue;
TextColor:=clBlack;
Mashtab:=1;
MyCanvas:=Canvas;
State:=msNewPoint;
FDrawCoord:=false;
end;
procedure TIO.RemovePoint(Num: integer);
var j:integer;N,MPenPos:TPoint;
begin
{with MyCanvas do begin
Pen.Width:=2;
Pen.Color:=RebroColor;
Pen.Mode:=pmXor;
Pen.Style:=psSolid;
MPenPos:=MyDraw.FindByNumber(Num);
for j:=1 to MyData.Dimension do
if MyData.Matrix[Num,j]=1 then begin
N:=MyDraw.FindByNumber(j);
PolyLine([MPenPos,N]);
end;}
{ Pen.Mode:=pmNot;
for j:=1 to MyData.Dimension do
if MyData.Matrix[Num,j]=1 then begin
N:=MyDraw.FindByNumber(j);
PolyLine([MPenPos,N]);
end;
end;}
MyData.Remove(Num);
MyDraw.Remove(Num);
end;
end.
Модуль визуального отображения графа в окне программы:
unit DrawingObject;
interface
uses
Classes, Windows, Graphics,dialogs,SysUtils;
type
Colors=(Red,RedLight,Blue,Yellow,Green,Purple);
Obj=record
Place:TRect;
PlaceX,PlaceY:integer;
Color:Colors;
end;
TDrawingObject = class(TObject)
protected
MyCanvas:TCanvas;
public
Dim:integer;
Bitmaps:array[1..6]of TBitmap;
Arr:array of Obj;
constructor Create(Canvas:TCanvas);
procedure Remove(Num:integer);
procedure NewPoint(x,y:integer);
procedure DrawSelf(Num:integer);
procedure DrawSelfXY(X,Y:integer);
function HasPoint(Num,X,Y:integer): Boolean;
destructor Destroy;
procedure DrawAll;
procedure Clear;
procedure Save(FileName:string);
procedure Load(FileName:string);
procedure SetActive(Num:integer);
procedure SetUnActive(Num:integer);
procedure SetAllUnActive;
procedure Move(number,x,y:integer);
procedure SetColor(Num:integer;NewColor:byte);
function FindByNumber(Num:integer): TPoint;
function FindNumberByXY(X,Y:integer):integer;
end;
var MyDraw:TDrawingObject;
implementation
procedure TDrawingObject.Clear;
begin
Dim:=0;
Arr:=nil;
end;
procedure TDrawingObject.NewPoint(x,y:integer);
begin
inc(Dim);
SetLength(Arr,Dim+1);
with Arr[Dim] do
begin
PlaceX:=x;
PlaceY:=y;
Place.Left:=x-Bitmaps[1].Width div 2;
Place.Top:=y-Bitmaps[1].Width div 2;
Place.Right:=x+Bitmaps[1].Width div 2;
Place.Bottom:=y+Bitmaps[1].Width div 2;
Color:=Red;
end;
end;
constructor TDrawingObject.Create(Canvas:TCanvas);
var i:byte;
begin
MyCanvas:=Canvas;
Dim:=0;
for i:=1 to 6 do
Bitmaps[i]:=TBitmap.Create;
Bitmaps[1].LoadFromResourceName(hInstance,'nBit');
Bitmaps[2].LoadFromResourceName(hInstance,'aBit');
Bitmaps[3].LoadFromResourceName(hInstance,'Blue');
Bitmaps[4].LoadFromResourceName(hInstance,'Yellow');
Bitmaps[5].LoadFromResourceName(hInstance,'Green');
Bitmaps[6].LoadFromResourceName(hInstance,'Purple');
for i:=1 to 6 do
Bitmaps[i].Transparent:=True;
end;
procedure TDrawingObject.DrawSelfXY(X,Y:integer);
begin
DrawSelf(FindNumberByXY(X,Y));
end;
procedure TDrawingObject.DrawSelf(Num:integer);
begin
with Arr[Num] do
case Color of
Red: MyCanvas.Draw(Place.Left,Place.Top,Bitmaps[1]);
RedLight: MyCanvas.Draw(Place.Left,Place.Top,Bitmaps[2]);
Blue: MyCanvas.Draw(Place.Left,Place.Top,Bitmaps[3]);
Green: MyCanvas.Draw(Place.Left,Place.Top,Bitmaps[4]);
Yellow: MyCanvas.Draw(Place.Left,Place.Top,Bitmaps[5]);
Purple: MyCanvas.Draw(Place.Left,Place.Top,Bitmaps[6]);
else
MyCanvas.Draw(Place.Left,Place.Top,Bitmaps[1]);
end;
end;
function TDrawingObject.HasPoint(Num,X,Y:integer): Boolean;
begin
with Arr[Num] do
if(X >= Place.Left) and (X <= Place.Right)
and (Y >= Place.Top) and (Y <= Place.Bottom)then
Result:= True
else
Result:= False;
end;
procedure TDrawingObject.DrawAll;
var
i: Integer;
begin
for i:=1 to Dim do
DrawSelf(i);
end;
function TDrawingObject.FindByNumber(Num:integer): TPoint;
begin
Result.x:= Arr[Num].PlaceX;
Result.y:= Arr[Num].PlaceY;
end;
function TDrawingObject.FindNumberByXY(X,Y:integer):integer;
var
i: Integer;
begin
Result:=-1;
for i:=1 to Dim do
if HasPoint(i,X,Y) then
begin
Result:=i;
Exit;
end;
end;
procedure TDrawingObject.SetUnActive(Num:integer);
begin
Arr[Num].Color:=Red;
DrawSelf(Num);
end;
destructor TDrawingObject.Destroy;
var i:byte;
begin
for i:=1 to 6 do
Bitmaps[i].Free;
end;
procedure TDrawingObject.Save(FileName:string);
var stream: TWriter;
st:TFileStream;
i:integer;
begin
try
st:=TFileStream.Create(FileName,fmCreate);
stream:= TWriter.Create(st,256);
stream.WriteInteger(Dim);
for i:=1 to Dim do
begin
stream.WriteBoolean(true);
stream.WriteInteger(Arr[i].Place.Left);
stream.WriteInteger(Arr[i].Place.Top);
stream.WriteInteger(Arr[i].Place.Right);
stream.WriteInteger(Arr[i].Place.Bottom);
stream.WriteInteger(Arr[i].PlaceX);
stream.WriteInteger(Arr[i].PlaceY);
end;
finally
stream.Free;
st.Free;
end;
end;
procedure TDrawingObject.Load(FileName:string);
var stream: TReader;
i:integer;
st:TFileStream;
s:boolean;
begin
try
st:=TFileStream.Create(FileName,fmOpenRead);
stream:= TReader.Create(st,256);
Dim:=stream.ReadInteger;
SetLength(Arr,Dim+1);
for i:=1 to Dim do
begin
Arr[i].Color:=Red;
s:=stream.ReadBoolean;
Arr[i].Place.Left:=stream.ReadInteger;
Arr[i].Place.Top:=stream.ReadInteger;
Arr[i].Place.Right:=stream.ReadInteger;
Arr[i].Place.Bottom:=stream.ReadInteger;
Arr[i].PlaceX:=stream.ReadInteger;
Arr[i].PlaceY:=stream.ReadInteger;
end;
finally
stream.Free;
st.Free;
end;
end;
procedure TDrawingObject.Remove(Num:integer);
var i:integer;
begin
for i:=Num to Dim-1 do
Arr[i]:=Arr[i+1];
Dec(Dim);
SetLength(Arr,Dim+1);
DrawAll;
end;
procedure TDrawingObject.SetActive(Num:integer);
begin
Arr[Num].Color:=RedLight;
DrawSelf(Num);
end;
procedure TDrawingObject.SetAllUnActive;
var i:byte;
begin
for i:=1 to Dim do
Arr[i].Color:=Red;
end;
procedure TDrawingObject.SetColor(Num:integer;NewColor:Byte);
begin
case NewColor of
1: Arr[Num].Color:=Red;
2: Arr[Num].Color:=RedLight;
3: Arr[Num].Color:=Blue;
4: Arr[Num].Color:=Green;
5: Arr[Num].Color:=Yellow;
6: Arr[Num].Color:=Purple;
end;
DrawSelf(Num);
end;
{$R bitmaps\shar.res}
procedure TDrawingObject.Move(number, x, y:integer);
begin
with Arr[number] do
begin
PlaceX:=x;
PlaceY:=y;
Place.Left:=x-Bitmaps[1].Width div 2;
Place.Top:=y-Bitmaps[1].Width div 2;
Place.Right:=x+Bitmaps[1].Width div 2;
Place.Bottom:=y+Bitmaps[1].Width div 2;
//Color:=Red;
end;
DrawSelf(number);
end;
end.
Модуль организации и управления данными о графе в память компьютера:
unit Data;
interface
uses Dialogs,Classes,SysUtils;
type TData=class
public
LengthActive:boolean;
Dimension: integer;
Oriented:boolean;
Matrix: array of array of Integer;
MatrixLength: array of array of Integer;
procedure Clear;
procedure NewPoint;
procedure Rebro(First,Second:integer);
procedure SetRebroLength(First,Second,Length:integer);
procedure Save(FileName:string);
procedure Load(FileName:string);
procedure Remove(Num:integer);
constructor Create;
end;
var MyData:TData;
implementation
constructor TData.Create;
begin Clear;
end;
procedure TData.Clear;
begin Oriented:=false;
LengthActive:=True;
Matrix:=nil;
MatrixLength:=nil;
Dimension:=0;
end;
procedure TData.NewPoint;
begin
inc(Dimension);
SetLength(Matrix,Dimension+1,Dimension+1);
if LengthActive then
SetLength(MatrixLength,Dimension+1,Dimension+1);
end;
procedure TData.Rebro(First,Second:integer);
begin
Matrix[First,Second]:=1;
Matrix[Second,First]:=1;
end;
procedure TData.Save(FileName:string);
var stream: TWriter;
st:TFileStream;
i,j:integer;
begin
try
st:=TFileStream.Create(FileName,fmCreate);
stream:= TWriter.Create(st,256);
stream.WriteInteger(Dimension);
stream.WriteBoolean(LengthActive);
stream.WriteBoolean(Oriented);
for i:=1 to Dimension do
for j:=1 to Dimension do
stream.WriteInteger(Matrix[i,j]);
for i:=1 to Dimension do
for j:=1 to Dimension do
stream.WriteInteger(MatrixLength[i,j]);
finally
stream.Free;
st.Free;
end;
end;
procedure TData.Load(FileName:string);
var stream: TReader;
i,j:integer;
st:TFileStream;
begin
try
st:=TFileStream.Create(FileName,fmOpenRead);
stream:= TReader.Create(st,256);
Dimension:=stream.ReadInteger;
SetLength(Matrix,Dimension+1,Dimension+1);
SetLength(MatrixLength,Dimension+1,Dimension+1);
LengthActive:=stream.ReadBoolean;
Oriented:=stream.ReadBoolean;
for i:=1 to Dimension do
for j:=1 to Dimension do
Matrix[i,j]:=stream.ReadInteger;
for i:=1 to Dimension do
for j:=1 to Dimension do
MatrixLength[i,j]:=stream.ReadInteger;
finally
stream.Free;
st.Free;
end;
end;
procedure TData.Remove(Num:integer);
var i,j:integer;
begin
for i:=Num to Dimension-1 do
for j:=1 to Dimension do
begin
Matrix[j,i]:=Matrix[j,i+1];
MatrixLength[j,i]:=MatrixLength[j,i+1];
end;
for i:=Num to Dimension-1 do
for j:=1 to Dimension-1 do
begin
Matrix[i,j]:=Matrix[i+1,j];
MatrixLength[i,j]:=MatrixLength[i+1,j];
end;
Dec(Dimension);
SetLength(Matrix,Dimension+1,Dimension+1);
SetLength(MatrixLength,Dimension+1,Dimension+1);
end;
procedure TData.SetRebroLength(First,Second,Length:integer);
begin
MatrixLength[First,Second]:=Length;
MatrixLength[Second,First]:=Length;
end;
end.
Модуль определения кратчайшего пути в графе:
unit MinLength;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Dialogs,
StdCtrls,IO,Data,AbstractAlgorithmUnit;
type
TMinLength = class(TAbstractAlgorithm)
private
StartPoint:integer;
EndPoint:integer;
First:Boolean;
Lymbda:array of integer;
function Proverka:Boolean;
public
procedure Make;
end;
var
MyMinLength: TMinLength;
implementation
uses MainUnit, Setting;
procedure TMinLength.Make;
var i,j: integer;
PathPlace,TempPoint:Integer;
flag:boolean;
begin
with MyData do begin
StartPoint:=MyIO.FirstPoint;
EndPoint:=MyIO.LastPoint;
SetLength(Lymbda,Dimension+1);
SetLength(Path,Dimension+1);
for i:=1 to Dimension do
Lymbda[i]:=100000;
Lymbda[StartPoint]:=0;
repeat
for i:=1 to Dimension do
for j:=1 to Dimension do
if Matrix[i,j]=1 then
if ((Lymbda[j]-Lymbda[i]) > MatrixLength[j,i])
then Lymbda[j]:=Lymbda[i] + MatrixLength[j,i];
until Proverka;
Path[1]:= EndPoint;
j:=1;
PathPlace:=2;
repeat
TempPoint:=1;
Flag:=False;
repeat
if (Matrix[ Path[ PathPlace-1 ],TempPoint] =1)and (
Lymbda[ Path[ PathPlace-1] ] =
(Lymbda[TempPoint] + MatrixLength[ Path[PathPlace-1 ], TempPoint]))
then Flag:=True
else Inc(TempPoint);
until Flag;
Path[ PathPlace ]:=TempPoint;
inc(PathPlace);
MyIO.DrawPath(Path[ PathPlace-2 ],Path[ PathPlace -1],true);
// ShowMessage('f');
until(Path[ PathPlace - 1 ] = StartPoint);
// MyIO.DrawPath(Path[ PathPlace-1 ],Path[ PathPlace ],true);
end;
end;
function TMinLength.Proverka:Boolean;
var i,j:integer;
Flag:boolean;
begin
i:=1;
Flag:=False;
With MyData do begin
repeat
j:=1;
repeat
if Matrix[i,j]=1 then
if (Lymbda[j]-Lymbda[i])>MatrixLength[j,i]then Flag:=True;
inc(j);
until(j>Dimension)or(Flag);
inc(i);
until(i>Dimension)or(Flag);
Result:=not Flag;
end;
end;
end.