44977 (Нахождение кратчайшего пути), страница 4

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

( 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.

47