Теория графов

  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 ;