Нахождение кратчайшего пути

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-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=(k*X+b-8) )and ( YDimension);

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.Top) and (Y 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.

-----------------------

[pic]

[pic]

[pic]

[pic]

Страницы: 1, 2, 3, 4