6.2 delphi

unit MainUnit;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Grids, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Description1: TLabel;
    InputM: TEdit;
    InputN: TEdit;
    Create: TButton;
    InfoM: TLabel;
    InfoN: TLabel;
    Matrix: TStringGrid;
    Description2: TLabel;
    Help: TLabel;
    ElementA: TButton;
    ElementB: TButton;
    MaxPath: TButton;
    Timer1: TTimer;
    procedure InputMKeyPress(Sender: TObject; var Key: Char);
    procedure InputNKeyPress(Sender: TObject; var Key: Char);
    procedure InputMChange(Sender: TObject);
    procedure InputNChange(Sender: TObject);
    procedure CreateClick(Sender: TObject);
    procedure MatrixKeyPress(Sender: TObject; var Key: Char);
    procedure MatrixSetEditText(Sender: TObject; ACol, ARow: Integer;
      const Value: string);
    procedure ElementAClick(Sender: TObject);
    procedure MatrixSelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure ElementBClick(Sender: TObject);
    procedure MaxPathClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
    Elements = record
      Elem : Integer;
      I : Byte;
    end;
    VertexLabel = record
      Vertex : Integer;
      Labels : String[1];
    end;
    PList = ^TNode;
    TNode = record
        Next : PList;
        Data : String;
    end;
    PListOfLists = ^TList;
    TList = record
        Next : PListOfLists;
        Data : PList;
    end;
type
    TMatrix = array of array of elements;
    TAdjacencyMatrix = array of array of Byte;

var
    Form1: TForm1;
    Arr: TMatrix;
    AdjacencyMatrix : TAdjacencyMatrix;
    SelectA, SelectB : Boolean;
    I1, J1, I2, J2 : Integer;
    VertexLabels : Array of VertexLabel;

implementation

{$R *.dfm}

procedure TForm1.CreateClick(Sender: TObject);
var
    M, N : Integer;
    IsCorrect : Boolean;
begin
    IsCorrect := True;
    try
        M := StrToInt(InputM.Text);
    except
        IsCorrect := False;
        MessageBox(Form1.Handle, Pchar('Проверьте поле для ввода кол-ва строк матрицы.'), 'Ошибка', MB_ICONSTOP);
    end;
    If IsCorrect then
    begin
        try
            N := StrToInt(InputN.Text);
        except
            IsCorrect := False;
            MessageBox(Form1.Handle, Pchar('Проверьте поле для ввода кол-ва столбцов матрицы.'), 'Ошибка', MB_ICONSTOP);
        end;
    end;
    If IsCorrect then
    begin
        SetLength(Arr, M, N);
        Matrix.ColCount := N;
        Matrix.RowCount := M;
        Matrix.Visible := True;
    end;
end;

procedure TForm1.ElementAClick(Sender: TObject);
Var
    Str : String;
begin
    Help.Visible := True;
    SelectA := True;
    Str := Help.Caption;
end;

procedure TForm1.ElementBClick(Sender: TObject);
begin
    Help.Visible := True;
    SelectB := True;
end;

procedure TForm1.InputMChange(Sender: TObject);
Const
    STR1 = 'Элемент a';
    STR2 = 'Элемент b';
Var
    I, J: Integer;
begin
    If (Length(InputM.Text) = 0) or (Length(InputN.Text) = 0)  then
        Create.Enabled := False
    else
        Create.Enabled := True;
    For I := 0 to Matrix.ColCount - 1 do
        For J := 0 to Matrix.RowCount - 1 do
            Matrix.Cells[I, J] := '';

    ElementA.Visible := False;
    ElementB.Visible := False;
    ElementA.Caption := STR1;
    ElementB.Caption := STR2;
    Help.Visible := False;
    MaxPath.Visible := False;
    Matrix.Options := Matrix.Options+[GoEditing];
end;

procedure TForm1.InputMKeyPress(Sender: TObject; var Key: Char);
begin
    If (Key = #13) and (Create.Enabled) then
        Create.Click;
    If (Not(Key In ['1'..'5', #08, #46])) Then
        Key := #0;
    If Key = '.' then
        Key := Char(0);
end;

procedure TForm1.InputNChange(Sender: TObject);
Const
    STR1 = 'Элемент a';
    STR2 = 'Элемент b';
Var
    I, J: Integer;
begin
    If (Length(InputM.Text) = 0) or (Length(InputN.Text) = 0)  then
        Create.Enabled := False
    else
        Create.Enabled := True;
    For I := 0 to Matrix.ColCount - 1 do
        For J := 0 to Matrix.RowCount - 1 do
            Matrix.Cells[I, J] := '';

    ElementA.Visible := False;
    ElementB.Visible := False;
    ElementA.Caption := STR1;
    ElementB.Caption := STR2;
    Help.Visible := False;
    MaxPath.Visible := False;
    Matrix.Options := Matrix.Options+[GoEditing];
end;

procedure TForm1.InputNKeyPress(Sender: TObject; var Key: Char);
begin
    If (Key = #13) and (Create.Enabled) then
        Create.Click;
    If (Not(Key In ['1'..'5', #08, #46])) Then
        Key := #0;
    If Key = '.' then
        Key := Char(0);
end;

procedure TForm1.MatrixKeyPress(Sender: TObject; var Key: Char);
Var
    I, J: Integer;
    IsCorrect : Boolean;
begin
    If (Not(Key In ['0'..'9', #08, #46, '-'])) Then
        Key := #0;
    If Key = '.' then
        Key := Char(0);
    With Sender As TStringGrid Do
    Begin
        If (Length(Matrix.Cells[Col, Row]) > 2) then
            If (Not(Key In [#08, #46])) Then
                Key := #0;
        If (Length(Matrix.Cells[Col, Row]) > 0) and (Key = '-')  then
            Key := #0;
    End;
end;

procedure TForm1.MatrixSelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
Const
    STR1 = 'Элемент a';
    STR2 = 'Элемент b';
begin
    If SelectA then
    begin
        I1 := ACol;
        J1 := ARow;
        ElementA.Caption := STR1 + ' [' + IntToStr(I1 + 1) + ', ' + IntToStr(J1 + 1) + ']';
        SelectA := False;
        Matrix.Options := Matrix.Options-[GoEditing];
    end;
    If SelectB then
    begin
        I2 := ACol;
        J2 := ARow;
        ElementB.Caption := STR2 + ' [' + IntToStr(I2 + 1) + ', ' + IntToStr(J2 + 1) + ']';
        SelectB := False;
        Matrix.Options := Matrix.Options-[GoEditing];
    end;
    If (ElementA.Caption <> STR1) and (ElementB.Caption <> STR2) then
        MaxPath.Visible := True;
end;

procedure TForm1.MatrixSetEditText(Sender: TObject; ACol, ARow: Integer;
  const Value: string);
Var
    I, J : Integer;
    IsCorrect : Boolean;
begin
    IsCorrect := True;
    For I := 0 to Matrix.ColCount  - 1 do
        For J := 0 to Matrix.RowCount - 1 do
            If (Length(Matrix.Cells[I, J]) = 0) Then
            begin
                ElementA.Visible := False;
                ElementB.Visible := False;
                IsCorrect := False;
                Break;
            end;
    If IsCorrect then
    begin
        ElementA.Visible := True;
        ElementB.Visible := True;
    end;

end;

procedure TransformMatrixToAdjacencyMatrix(Arr: TMatrix; N, M: Integer);
Const
    ONE: Byte = 1;
Var
    I, J: Integer;
begin
    SetLength(AdjacencyMatrix, N * M, N * M);
    For I := 0 to M-1 do
    begin
        For J := 0 to N-1 do
        begin
            if (I+1 < M) then
            begin
                AdjacencyMatrix[Arr[I][J].I - 1][Arr[I+1][J].I - 1] := ONE;
                AdjacencyMatrix[Arr[I+1][J].I - 1][Arr[I][J].I - 1] := ONE;
            end;
            if (I > 0) then
            begin
                AdjacencyMatrix[Arr[I][J].I - 1][Arr[I-1][J].I - 1] := ONE;
                AdjacencyMatrix[Arr[I-1][J].I - 1][Arr[I][J].I - 1] := ONE;
            end;
            if (J+1 < N) then
            begin
                AdjacencyMatrix[Arr[I][J].I - 1][Arr[I][J+1].I - 1] := ONE;
                AdjacencyMatrix[Arr[I][J+1].I - 1][Arr[I][J].I - 1] := ONE;
            end;
            if (J > 0) then
            begin
                AdjacencyMatrix[Arr[I][J].I - 1][Arr[I][J-1].I - 1] := ONE;
                AdjacencyMatrix[Arr[I][J-1].I - 1][Arr[I][J].I - 1] := ONE;
            end;
        end;
    end;
end;

function IsContains (CurrentPath : PList; Str : String) : Boolean;
Var                                                    // надо проследить поведение этой функции
    Contains : Boolean;
Begin
    Contains := False;
    While CurrentPath <> nil Do
    begin
        If CurrentPath.Data = Str then
        begin
            Contains := True;
            CurrentPath := nil;
        end
        else
        begin
            CurrentPath := CurrentPath.Next;
        end;
    end;
    IsContains := Contains;
End;

procedure AddPathInAllPaths (var AllPaths : PListOfLists; List : PList);
Var
    Head, NewItem : PListOfLists;
Begin
    New(NewItem);
    NewItem^.Data := List;
    NewItem^.Next := nil;
    if AllPaths = nil then
        AllPaths := NewItem
    else
    begin
        Head := AllPaths;
        while Head^.Next <> nil Do
            Head := Head^.Next;
        Head^.Next := NewItem;
    end;
End;

procedure AddinList(var List: PList; Str: String);
var
    NewItem, Head: PList;
begin
    New(NewItem);
    NewItem^.Data := Str;
    NewItem^.Next := nil;
    if List = nil then
        List := NewItem
    else
    begin
        Head := List;
        while Head^.Next <> nil do
            Head := Head^.Next;
        Head^.Next := NewItem;
    end;
end;



procedure RemoveFromList(var List: PList);
var
    Head, Prev: PList;
begin
    Head := List;
    Prev := nil;
    while Head^.Next <> nil do
    begin
        Prev := Head;
        Head := Head^.Next;
    end;
    if Prev = nil then
        List := nil
    else
        Prev^.Next := nil;
    Dispose(Head);
end;


procedure AllPathsDFS (CurrentIndex, FinishIndex : Integer; CurrentPath : PList; var AllPaths : PListOfLists);
Var
    I : Integer;
begin
    If (CurrentIndex = FinishIndex) then
    Begin
        AddPathInAllPaths(AllPaths, CurrentPath);
    End
    else
    begin
        For I := Low(AdjacencyMatrix[CurrentIndex]) To High(AdjacencyMatrix[CurrentIndex]) Do
        begin
            If (AdjacencyMatrix[CurrentIndex][I] = 1) and Not(IsContains(CurrentPath, VertexLabels[I].Labels)) then
            begin
                AddinList(CurrentPath, Vertexlabels[I].Labels);
                AllPathsDFS(I, FinishIndex, CurrentPath, AllPaths);
                //RemoveFromList(CurrentPath);
            end;
        end;
    end;
end;

function GetAllPaths(Start, Finish : String) : PListOfLists;
Var
    StartIndex, EndIndex, I : Integer;
    AllPaths : PListOfLists;
    CurrentPath : PList;
    IsCorrect : Boolean;
Begin
    StartIndex := -1;
    EndIndex := -1;
    For I := Low(VertexLabels) To High(VertexLabels) do
    begin
        If Start = VertexLabels[I].Labels then
            StartIndex := I;
        If Finish = VertexLabels[I].Labels then
            EndIndex := I;
    end;
    IsCorrect := True;
    If (StartIndex = -1) or (EndIndex = -1) then
    Begin
        IsCorrect := False;
        GetAllPaths := AllPaths;
    End;
    AllPaths := nil;
    CurrentPath := nil;
    If IsCorrect then
    Begin
        AddinList(CurrentPath, Start);
        AllPathsDFS(StartIndex, EndIndex, CurrentPath, AllPaths);
        GetAllPaths := AllPaths;
    End;
End;

function FindSum (List : PList) : Integer;
Var
    Sum, I : Integer;
Begin
    Sum := 0;
    For I := Low(VertexLabels) To High(VertexLabels) Do
    begin
        if IsContains(List, VertexLabels[I].Labels) then
            Sum := Sum + VertexLabels[I].Vertex;
    end;
    FindSum := Sum;
End;

function ShowMaxPaths(List : PList) : String;
Var
    Str : String;
Begin
    while List <> nil do
    begin
        Str := Str + List.Data + ' ';
        List := List.Next;
    end;
    ShowMaxPaths := Str;
End;

function FindPaths(Start, Finish : String) : String;
Var
    Sum, Max, I: Integer;
    Str : String;
    Head, AllPaths : PListOfLists;
Begin
    Max := 0;
    AllPaths := GetAllPaths(Start, Finish);
    Head := AllPaths;
    While Head <> nil Do
    begin                             // обособить в функцию
        Sum := FindSum(Head.Data);
        If Sum > Max then
            Max := Sum;
        Head := Head.Next;
    end;

    While AllPaths <> nil Do
    begin
        If Max = FindSum(AllPaths.Data) then
            Str := Str + ShowMaxPaths(AllPaths.Data) + #13#10;
        AllPaths := AllPaths.Next;
    end;
    //это все для примера, так как после этого не будет AllPaths
    FindPaths := Str;
End;


procedure TForm1.MaxPathClick(Sender: TObject;);
Var
    I, J, K : Integer;
    IsCorrect : Boolean;
    Vertex : Char;
    Start, Finish : String[1];
    Index : Byte;
Const
    STR1 = 'Элемент a';
    STR2 = 'Элемент b';
begin
    IsCorrect := True;
    Index := 1;
    If IsCorrect then
    begin
        try
        For I := 0 to Matrix.ColCount - 1 do
            For J := 0 to Matrix.RowCount - 1 do
            Begin
                Arr[J, I].Elem := StrToInt(Matrix.Cells[I,J]);
                Arr[J, I].I := Index;
                Inc(Index);
            End;
        except
            IsCorrect := False;
            MessageBox(Form1.Handle, Pchar('Проверьте содержимое матрицы. В клеточках должны быть только целочисленные значения.'), 'Ошибка', MB_ICONSTOP);
            ElementA.Visible := False;
            ElementB.Visible := False;
            ElementA.Caption := STR1;
            ElementB.Caption := STR2;
            Help.Visible := False;
            MaxPath.Visible := False;
            Matrix.Options := Matrix.Options+[GoEditing];
        end;
    end;
    If IsCorrect then
    begin
        TransformMatrixToAdjacencyMatrix(Arr, Matrix.ColCount, Matrix.RowCount);
        K := 0;
        Vertex := 'A';
        SetLength(VertexLabels, Matrix.RowCount * Matrix.ColCount);
        For I := 0 to Matrix.ColCount - 1 do
            For J := 0 to Matrix.RowCount - 1 do
            begin
                VertexLabels[K].Vertex := Arr[J, I].Elem;
                VertexLabels[K].Labels := Vertex;
                If (I = I1) and (J = J1) then
                    Start := Vertex;
                If (I = I2) and (J = J2) then
                    Finish := Vertex;
                Vertex := Chr(Ord(Vertex) + 1);
                Inc(K);
            end;
        Description1.Caption := FindPaths(Start, Finish);
        Description2.Visible := False;  //это для примера!
    end;
end;

end.