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

  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.