unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Spin, Grids, ExtCtrls, Buttons,
  Param, ImgList;

type
  TMainForm = class(TForm)
    WaightGrid: TStringGrid;
    WaightLabel: TLabel;
    StartSpinEdit: TSpinEdit;
    AnswerLabel: TLabel;
    AnswerEdit: TEdit;
    CountBtn: TBitBtn;
    MetodRadioGroup: TRadioGroup;
    LongLabel: TLabel;
    LongEdit: TEdit;
    ImageList1: TImageList;
    ImageList2: TImageList;
    procedure WaightGridDblClick(Sender: TObject);
    procedure ChangeTable;
    procedure CountBtnClick(Sender: TObject);
    procedure LoadBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

const
  MaxVer = 50;  {Максимальное кол-во вершин в графе}

type
  {Матрица весов ориентированного графа}
  MatrType=array[1..MaxVer, 1..MaxVer] of Double;

var
  MainForm: TMainForm;
  {Главная матрица - веса в ориентированном графе}
  Matr: MatrType;
  N: 1..MaxVer; {Количество вершин в графе}

implementation

{$R *.DFM}

procedure TMainForm.WaightGridDblClick(Sender: TObject);
{Изменение информации в выделенной ячейке}
var
  Tit: string;  {Название ячейки}
  S: string;    {Введённое число}
  Default: string;{Значение по-умолчанию}
  Code: integer;{Контроль преобразования}
label
  loop;
begin
  Tit:='A'+IntToStr(WaightGrid.Row)+'-A'+IntToStr(WaightGrid.Col);
  S:='';  {Начальная инициализация строки}
loop:
  {Ввод строки}
  Default:=S;
  S:=InputBox('Длина пути:','Введите расстояние между пунктами: '+Tit, Default);
  if S=Default then Exit;  {Нажали кнопку "Отмена"}
  S:=Trim(S); {Убираем окантовку из пробелов}
  Val(S, Matr[WaightGrid.Row, WaightGrid.Col], Code);
  if Code<>0 then goto loop; {Неправильный ввод}
  {Отрисовываем изменённую ячейку}
  With WaightGrid do
    Cells[Col, Row]:=FloatToStrF(Matr[Row, Col],ffFixed,10,6)
end;  {TMainForm.WaightGridDblClick}

procedure TMainForm.ChangeTable;
{Изменение и перерисовка изобр. таблицы при изменении матр.}
var
  i, j: byte;  {Индексы доступа к массивам}
begin
  with WaightGrid do
    begin
      {Устанавливаем редактор начальной вершины}
      StartSpinEdit.Value:=1;
      StartSpinEdit.MaxValue:=N;
      {Устанавливаем размер таблицы}
      RowCount:=N+1;  ColCount:=N+1;
      {Заголовки строк}
      for i:=1 to N do Cells[0, i]:='A'+IntToStr(i);
      {Заголовки колонок}
      for j:=1 to N do Cells[j, 0]:='A'+IntToStr(j);
      {Выводим матрицу}
      for i:=1 to N do
        for j:=1 to N do
          Cells[j,i]:=FloatToStrF(Matr[i,j],ffFixed,10,6)
    end;
  {Стираем ответ}
  AnswerEdit.Text:=''
end;  {TMainForm.ChangeTable}

procedure TMainForm.CountBtnClick(Sender: TObject);
{Решаем задачу "о коммивояжёре"}
type
  {Перечисление вершин кратчайшего пути}
  ShortPath = array [0..MaxVer+1] of ShortInt;  {Список вершин}

function Exhaustive(var Matr: MatrType; N, Ver: Byte; var Ans: ShortPath): Boolean;
{Решает задачу "о коммивояжёре" методом "полного
перебора" возможных путей.
  Matr - матрица весов в орграфе на N вершинах.
         Исходная вершина имеет номер Ver
  Ans  - оптимальный путь в графе
Функция возвращает True, если задача решена и False,
если в графе вообще нет гамильтоновых циклов }

const
  Eps = 1.E-10;    {Машинный ноль}

function PathLength(var Path: ShortPath): Double;
{Вычисляет длину пути из N+1 вершин или возвращает
0, если пути не существует (некоторые рёбра отсутствуют)}
var
  i: Byte;
  Res: Double;  {Накопление сумму длин путей}
begin
  Res:=0;
  for i:=1 to N do
    if Matr[Path[i],Path[i+1]]<=Eps then
      begin
        Result:=0.0;
        Exit
      end
    else
      Res:=Res+Matr[Path[i],Path[i+1]];
  Result:=Res
end;  {PathLength}

{Exhaustive}
var
{Переменнные для сравнений}
  Res: Double;  {}
  Tmp: Double;
  OldPath, CurPath: ShortPath;  {Старый и текущ. пути}
  j,k: Byte;
{Переменные для генерации перестановок}
  z,p,d: ShortPath;
  pm,dm,zpm: Short;
  i,m,w: Integer;
begin
  Res:=1.E301;
  {Запускаем генератор перестановок}
  for i:=1 to N do
    begin
      z[i]:=i; p[i]:=i; d[i]:=-1
    end;
  d[1]:=0;
  m:=N+1;
  z[0]:=m; z[N+1]:=m;
  while m<>1 do
    begin
      {Здесь получена очередная перестановка}
        {Формируем параметры для вычисления длины}
      CurPath[1]:=Ver;  {Начальная вершина}
      k:=1;
      for j:=1 to N do
        if z[j]<>Ver then   {Промежуточные вершины}
          begin
            Inc(k);
            CurPath[k]:=z[j]
          end;
      CurPath[N+1]:=Ver;  {Она же конечная}
        {Вычисляем длину}
      Tmp:=PathLength(CurPath);
      if Tmp>Eps then  {Есть цикл}
        if Tmp<Res then
          begin
            Res:=Tmp;
            OldPath:=CurPath
          end;
      {Продолжаем генерацию перестановок}
      m:=N;
      while z[p[m]+d[m]]>m do
        begin
          d[m]:=-d[m]; m:=m-1
        end;
      pm:=p[m]; dm:=pm+d[m]; w:=z[pm];
      z[pm]:=z[dm]; z[dm]:=w;
      zpm:=z[pm]; w:=p[zpm]; p[zpm]:=pm; p[m]:=w
    end;
  {Выписываем ответы}
  if Res<1.E300 then
    begin
      Result:=True;
      Ans:=OldPath
    end
  else
    Result:=False
end;  {Exhaustive}


function BranchAndBound(var Matr: MatrType; N, Ver: Byte;
                        var Ans: ShortPath): Boolean;
{Решает задачу "о коммивояжёре" методом "ветвей и
границ".
  Matr - матрица весов в орграфе на N вершинах (0-нет ребра).
         Исходная вершина имеет номер Ver
  Ans  - оптимальный путь в графе
Функция возвращает True, если задача решена и False,
если в графе вообще нет гамильтоновых циклов }

             {Описание констант}
const
  ZERO = 1.E-15;     {Машинный ноль}
  INFINITY = 1.E+30; {Машинная бесконечность}

             {Описание структур данных}
type
  {Описатель границы - вершины строящегося дерева}
  PBound = ^TBound;
  TBound = record
    M: MatrType;     {Матрица границы}
    Fi: Double;      {Значение оценочной функции на данной границе}
    RibCol: Byte;    {Количество отобранных ребер обхода на данной границе}
    Ribs: array [1..MaxVer, 1..2] of Byte; {Отобранные ребра: Ribs[i,1],
                      Ribs[i,2] начальная и конечная вершины ребра i}
    Pred: PBound     {Указатель на неразработ. границу предыдущего уровня}
  end;

         {Описание вспомогательных алгоритмов}
function BegVerInRibs(Ver: Byte; Bound: PBound): Boolean;
{Возвращает True, если вершина Ver является начальной
 вершиной какого-либо ребра Bound^.Ribs и False в
 противном случае}
var
  i: Byte;
begin
  BegVerInRibs := False;
  for i:=1 to Bound^.RibCol do
    if Bound^.Ribs[i,1] = Ver then
      begin
        BegVerInRibs := True;
        Break
      end
end;  {BegVerInRibs}

function EndVerInRibs(Ver: Byte; Bound: PBound): Boolean;
{Возвращает True, если вершина Ver является конечной
 вершиной какого-либо ребра Bound^.Ribs и False в
 противном случае}
var
  i: Byte;
begin
  EndVerInRibs := False;
  for i:=1 to Bound^.RibCol do
    if Bound^.Ribs[i,2] = Ver then
      begin
        EndVerInRibs := True;
        Break
      end
end;  {EndVerInRibs}

procedure ReductMatr(Bound: PBound; N: Byte);
{Осуществляет приведение матрицы Bound^.M размером NxN
 Увеличивает Bound^.Fi на сумму констант приведения}
var
  i,j: Byte;
  Min: Double;      {Миним. элемент в строке или столбце}
begin
  {Приведение по строкам}
  for i:=1 to N do
    if not BegVerInRibs(i, Bound) then
      begin
        Min := 2*INFINITY;
        {Ищем минимальный элемент}
        for j:=1 to N do
          if (EndVerInRibs(j, Bound)=False)and(Bound^.M[i,j]<Min) then
            Min := Bound^.M[i,j];
        {Производим приведение}
        Bound^.Fi := Bound^.Fi+Min;
        for j:=1 to N do
          if not EndVerInRibs(j, Bound) then
            Bound^.M[i,j] := Bound^.M[i,j]-Min
      end;
  {Приведение по столбцам}
  for j:=1 to N do
    if not EndVerInRibs(j, Bound) then
      begin
        Min := 2*INFINITY;
        {Ищем минимальный элемент}
        for i:=1 to N do
          if (BegVerInRibs(i, Bound)=False)and(Bound^.M[i,j]<Min) then
            Min := Bound^.M[i,j];
        {Производим приведение}
        Bound^.Fi := Bound^.Fi+Min;
        for i:=1 to N do
          if not BegVerInRibs(i, Bound) then
            Bound^.M[i,j] := Bound^.M[i,j]-Min
      end
end;  {ReductMatr}

procedure FindHeavyZero(Bound: PBound; N: Byte; var Row: Byte; var Col: Byte);
{Находит "самый тяжелый ноль" матрицы Bound^.M размером NxN и возвращает
строку Row и столбец Col в котором этот ноль был найден}
var
  TmpBound: TBound;  {Вспомогательная переменная для приведения матриц}
  MaxW: Double;      {Вес "самого тяжелого нуля"}
  i,j: Byte;
begin
  Row := 0;  {Еще ничего}
  Col := 0;  {не найдено}
  MaxW := -1.0;
  for i:=1 to N do
    if not BegVerInRibs(i, Bound) then
      for j:=1 to N do
        if not EndVerInRibs(j, Bound) then
          if Bound^.M[i,j] < ZERO then
            begin  {Нашли очередной ноль - подсчитать его вес}
              TmpBound := Bound^;
              TmpBound.M[i,j] := 2*INFINITY;
              TmpBound.Fi := 0.0;
              ReductMatr(@TmpBound, N);
              if TmpBound.Fi > MaxW then
                begin
                  Row := i;
                  Col := j;
                  MaxW := TmpBound.Fi
                end
            end
end;  {FindHeavyZero}

function IsCycle(Bound: PBound; V1, V2: Byte): Boolean;
{Проверяет, образует ли ребро (V1,V2) замкнутый контур с ребрами из
 Bound^.Ribs}
var
  i: Byte;
  V: Byte;      {Конечная вершина текущего построения}
  CycLen: Byte; {Количество ребер в текущем построении}
label
  loop;
begin
  IsCycle := False;
  V := V2;      {Начинаем строить цикл от ребра (V1,V2)}
  CycLen := 1;
  with Bound^ do
    while CycLen < RibCol+1 do
      begin
        for i:=1 to RibCol do
          if Ribs[i,1] = V then
            begin  {Нашли очередное ребро}
              V := Ribs[i,2];
              CycLen := CycLen + 1;
              if V = V1 then
                IsCycle:=True  {Контур замкнулся полностью}
              else
                goto loop      {Продолжим искать ребра}
            end;
        Break;  {Не находим продолжения обхода - выход}
loop:
      end
end;  {IsCycle}

procedure NewLevel(Bound: PBound; var Left: PBound; var Right: PBound);
{Разбивает границу Bound на левую и правую часть (Left и Right).
  - в левой части остаются все циклы, в которые входит ребро,
    соответствующее клетке с наиболее "тяжелым нулем" (список отобранных
    ребер пополняется данным ребром).
  - в правой части остаются все циклы в которые не входит ребро, отобранное
    для левой части
 Затем матрицы приводятся
}
var
  i,j,k: Byte;
  Row, Col: Byte;  {координаты "самого тяжелого нуля"}
begin
  {Находим "самый тяжелый ноль"}
  FindHeavyZero(Bound, N, Row, Col);
  {Создаем элемент Left}
  New(Left);
  Left^ := Bound^;  {Копируем структуру полностью}
  with Left^ do
    begin
      {Добавить ребро (Row, Col)}
      RibCol := RibCol+1;
      Ribs[RibCol,1]:=Row;
      Ribs[RibCol,2]:=Col;
      {Заменить на бесконечность клетки ребер,
       позволяющие замкнуть ребра из Ribs в цикл без обхода всех вершин}
      if RibCol < N-1 then
        {Нужно добавить в цикл более одного ребра - нельзя допускать,
         чтобы одно ребро завершило цикл}
        for i:=1 to N do
          if not BegVerInRibs(i, Left) then  {Строка не вычеркнута}
            for j:=1 to N do
              if not EndVerInRibs(j, Left) then  {Столбец не вычеркнут}
                if M[i,j] < INFINITY then {Ребро (i,j) существует}
                  if IsCycle(Left, i, j) then  {Оно может завершить цикл}
                    M[i,j] := 2*INFINITY  {Удаляем это ребро}
    end;
  ReductMatr(Left, N);  {Приводим матрицу}
  {Создаем элемент Right}
  New(Right);
  Right^ := Bound^;  {Копируем структуру полностью}
  Right^.M[Row, Col] := 2*INFINITY; {Убрать циклы, в которые входит (Row,Col)}
  ReductMatr(Right, N)  {Приводим матрицу}
end;  {NewLevel}

procedure BuildRecord(Bound: PBound; N: Byte);
{Превращение в рекорд границы Bound с матрицей NxN и одним невычеркнутым
ребром добавлением этого невычеркнутого ребра в список ребер Ribs}
var
  i,j: Byte;
begin
  with Bound^ do
    for i:=1 to N do
      {Ищем невычеркнутую строку}
      if not BegVerInRibs(i, Bound) then
        for j:=1 to N do
          {Ищем невычеркнутый столбец}
          if not EndVerInRibs(j, Bound) then
            begin  {Добавляем ребро (i,j) в множество Ribs}
              RibCol := RibCol + 1;
              Ribs[RibCol,1] := i;
              Ribs[RibCol,2] := j;
              Fi := Fi + M[i,j];
              Exit
            end
end;  {BuildRecord}

function BuildPath(Bound: PBound; var Matr: MatrType; N, BegVer: Byte;
                   var Path: ShortPath): Boolean;
{По лучшему рекорду Bound строит последовательный путь обхода Path, начиная
 с вершины BegVer. С помощью исходной весовой матрицы Matr размером NxN,
 подсчитывается длина пути. Если длина пути >= бесконечности, возвращается
 False - пути нет, иначе возвращается True}
var
  i,j: Byte;
  PathLen: Double;  {Длина пути}
begin
  PathLen := 0.0;
  Path[1] := BegVer;
  with Bound^ do
    begin
      for i:=2 to N do
        for j:=1 to RibCol do
          if Ribs[j,1] = Path[i-1] then
            begin
              Path[i] := Ribs[j,2];
              PathLen := PathLen + Matr[Path[i-1], Path[i]];
              Break
            end;
      Path[RibCol+1] := BegVer;
      PathLen := PathLen + Matr[Path[RibCol], Path[RibCol+1]]
    end;
  BuildPath := PathLen < INFINITY
end;  {BuildPath}

{BranchAndBound}
var
  i,j: Byte;
  WMatr: MatrType;   {Весовая матрица, где "нули" заменены на "бесконечность"}
  CurBound: PBound;  {Граница, разрабатываемая на текущем шаге}
  Left, Right: PBound;{Результаты разбиения границы на две дочерних}
  Rec: PBound;       {Текущий рекорд}
  TmpBound: PBound;  {Вспомогательная переменная для обхода списка}
label
  loop;
begin
  {По исходной матрице инициализируем рабочую}
  for i:=1 to N do
    for j:=1 to N do
      if Abs(Matr[i,j]) < ZERO then
        WMatr[i,j] := 2*INFINITY
      else
        WMatr[i,j] := Matr[i,j];
  {Инициализируем начальную границу рабочей матрицей}
  New(CurBound);
  with CurBound^ do
    begin
      M := WMatr;
      Fi := 0.0;
      RibCol := 0;
      Pred := NIL
    end;
  ReductMatr(CurBound, N); {Привести матрицу}
  {Основной цикл алгоритма - нахождение оптимального обхода коммивояжера}
loop:
  {Прямой ход алгоритма - разработка границ до получения рекорда}
  while CurBound^.RibCol < N-1 do
    begin
      {Разбиваем границу CurBound на две дочерних: Left и Right}
      NewLevel(CurBound, Left, Right);
      {Выбираем: какую из границ разрабатывать дальше}
      if Left^.Fi <= Right^.Fi then
        begin  {Идем налево}
          Right^.Pred := CurBound^.Pred;
          Left^.Pred := Right;
          Dispose(CurBound);
          CurBound := Left;
        end
      else
        begin  {Идем направо}
          Left^.Pred := CurBound^.Pred;
          Right^.Pred := Left;
          Dispose(CurBound);
          CurBound := Right;
        end
    end;
  {Имеем матрицу из 1-й клетки - превращаем ее в рекорд}
  BuildRecord(CurBound, N);
  Rec := CurBound;  {Зафиксировать ссылку на рекорд}
  CurBound := CurBound^.Pred; {Перейти на ближайшую неразработанную границу}
  {Обратный ход алгоритма - улучшение рекорда}
  while CurBound<>NIL do
    begin
      if CurBound^.Fi < Rec^.Fi then
        begin  {Начать разработку новой границы}
          Dispose(Rec);  {Освободить память, занятую рекордом}
          goto loop;
        end;
      TmpBound := CurBound;       {Подняться на уровень выше}
      CurBound := CurBound^.Pred; {и удалить}
      Dispose(TmpBound)           {отсекаемую границу}
    end;
  {Преобразовать набор ребер в рекорде в последовательный путь Ans}
  {(возвращается False, если найденный путь бесконечной длины)}
  BranchAndBound := BuildPath(Rec, WMatr, N, Ver, Ans);
  {Удалить рекорд}
  Dispose(Rec)
end;  {BranchAndBound}


{Главная программа}
var
  i: Byte;         {Индекс массива}
  S: String;       {Для формирования ответа}
  Res: Boolean;    {Результат выполнения метода решения}
  Ans: ShortPath;  {Ответ на задачу}
  PathLong: Double;{Длина выбранного пути}
begin
  {Договариваемся, что если в клетке Matr стоит 0,
  то этого ребра не существует}
  {Стираем предыдущий ответ}
  AnswerEdit.Text:='';
  LongEdit.Text:='';
  {Выбираем метод решения}
  case MetodRadioGroup.ItemIndex of
    0: Res:=Exhaustive(Matr,N,StartSpinEdit.Value,Ans);
    1: Res:=BranchAndBound(Matr,N,StartSpinEdit.Value,Ans)
  end;
  {Распечатываем результаты}
  if Res then
    begin
      {Выводим маршрут}
      S:='';
      for i:=1 to N+1 do
        begin
          if i>1 then S:=S+' -> ';
          S:=S+IntToStr(Ans[i])
        end;
      AnswerEdit.Text:=S;
      {Выводим длину пути}
      PathLong:=0.0;
      for i:=1 to N do
        PathLong:=PathLong+Matr[Ans[i],Ans[i+1]];
      LongEdit.Text:=FloatToStrF(PathLong,ffFixed,10,6)
    end
  else
    ShowMessage('Не найдено ни одного пути!')
end;  {TMainForm.CountBtnClick}

procedure TMainForm.LoadBtnClick(Sender: TObject);
{С помощью диалога устанавливает размеры матрицы
 весов, либо загружает ёё из файла}

{Читает файл для курсового проекта}
var
  name: string;     {Имя файла}
  f: file of char;  {Файл данных}
  c: char;          {Переменная для чтения данных}
  i, j: byte;       {Индексы}
  S: ShortString;   {Вспомогательная строка преобр.}
  Code: Integer;    {Контроль преобр.}
label
  loop, loop1;
begin
  {Вызываем диалог ввода параметров}
loop:
  if ParamDlg.ShowModal=mrCancel then Exit; {Отказ от ввода}
  if ParamDlg.RadioGroup1.ItemIndex=0 then
    begin    {Просто изменяем размеры}
      N := StrToInt(ParamDlg.SizeEdit.Text);
      ChangeTable;
      Exit
    end
  else
    begin    {Читаем таблицу из файла}
      if not FileExists(ParamDlg.FileEdit.Text)then
        begin
          ShowMessage('Неверное имя файла!');
          goto loop
        end
      else
        name:=ParamDlg.FileEdit.Text
    end;
  {Устанавливаем переключатель на метод "ветвей и границ".}
  MetodRadioGroup.ItemIndex:=1;
  {Открываем файл}
  AssignFile(f, name);
  reset(f);
  {Пропускаем заголовок}
  C:=' ';
  While C<>':' do Read(f,C);
  i:=0;  {Номер текущей строки}
  while true do
    begin
      C:=' ';
      while (C<>':') do Read(f, C);{До очередн. строки}
      Inc(i);
      j:=0;  {Номер текущего столбца}
      while (C<>'L') do
        begin {Читаем текущую строку}
          if Eof(f) then goto loop1;
          Read(f, C);
          if C in ['0'..'9','.'] then
            begin
              S:='';
              while  C in ['0'..'9','.'] do
                begin
                  S:=S+C;
                  Read(f, C);
                end;
              Inc(j);
              Val(S, Matr[i,j], Code)
            end
        end
    end;
loop1:
  CloseFile(f);
  N:=j;
  ChangeTable
end;  {TMainForm.LoadBtnClick}

procedure TMainForm.FormCreate(Sender: TObject);
{Начальная инициализация условия}
begin
  N:=4;
  ChangeTable
end;  {TMainForm.FormCreate}

end.