Решите пожалуйста! Паскаль!

Question

Решите пожалуйста! Паскаль!

---

Answer 1

Это в школе такое задают?:)

const
  MaxN = 42; { Ограничение на N }
  MaxG = 2 * MaxN + 1; { Ограничение на число вершин в графе }
  Infinity = 2147483647;{ "Бесконечное" расстояние }

var
  N: Integer;                 
  F: Text;
  Match: Array[1..MaxN]Of Record  { Входные     }
    X1, Y1, X2, Y2: Integer;                 {    данные    }
    Time: LongInt;                       
  End;                           
  NG: Integer;                                    {           }
  Vertex: Array[1..MaxG]Of Record   {           }
    X, Y: Integer;                                  { Граф }
  End;                                               {           }
  Edge, Distance: Array[1..MaxG, 1..MaxG]Of LongInt; 
  
  Res: Real;      { Минимальное время наполнения }
  ResX, ResY: Integer;{ Оптимальная точка подключения  }  

procedure Load;
var
  I: Integer;
begin
  Assign(F, 'Task3.In');
  ReSet(F);
  Read(F, N);
  for I := 1 To N Do 
    with Match[I] Do
      Read(F, X1, Y1, X2, Y2, Time);
  Close(F);
end;

function GetVertex(VX, VY: Integer): Integer;
  { Функция, возвращающая номер вершины с заданными координатами.
    При отсутствии нужной вершины она создаётся }
var
  I: Integer;
begin
  for I := 1 To NG Do
    with Vertex[I] Do
      if (X = VX) And (Y = VY) Then begin
        GetVertex := I;         Exit;
      end;
  Inc(NG); { Если нужная вершина не найдена }
  with Vertex[NG] Do 
  begin
    X := VX;     Y := VY;
    for I := 1 To NG - 1 Do 
    begin
      Edge[I, NG] := Infinity;
      Edge[NG, I] := Infinity;
    end;
    Edge[NG, NG] := 0;
  end;
  GetVertex := NG;
end;

procedure AddEdge(X1, Y1, X2, Y2: Integer; Time: Longint);
  { Функция, добавляющая ребро между двумя точками }
var
  A, B: Integer;
begin
  A := GetVertex(X1, Y1);
  B := GetVertex(X2, Y2);
  Edge[A, B] := Time;
  Edge[B, A] := Time;
end;

procedure BuildGraph;{ Процедура построения графа }
var
  I: Integer;
begin
  NG := 0;
  for I := 1 To N Do 
    with Match[I] Do 
    begin
      AddEdge(X1 * 2, Y1 * 2, X1 + X2, Y1 + Y2, Time);
      AddEdge(X1 + X2, Y1 + Y2, X2 * 2, Y2 * 2, Time);
    end;
end;

procedure FindShortestPaths;
var
  K, I, J: Integer;
begin
  Distance := Edge;
  for K := 1 To NG Do
    for I := 1 To NG Do 
      if Distance[I, K] < Infinity Then
        for J := 1 To NG Do 
          if Distance[K, J] < Infinity Then
            if Distance[I, K] + Distance[K, J] < Distance[I, J] Then
              Distance[I, J] := Distance[I, K] + Distance[K, J];
end;

function BurnAt(At: Integer): Extended;
  { Функция, вычисляющая время наполнения при подключении в точке At }
var
  I, J: Integer;
  Cur, ThisEdge: Real;
begin
  Cur := 0;
  for I := 1 To NG Do if Distance[At, I] > Cur Then Cur := Distance[At, I];
  for I := 1 To NG Do
    for J := I + 1 To NG Do 
      if Edge[I, J] < Infinity Then begin
        if (Distance[At, I] < Distance[At, J] + Edge[I, J]) And 
           (Distance[At, J] < Distance[At, I] + Edge[I, J]) Then 
        begin
          if Distance[At, I] < Distance[At, J] Then
            ThisEdge := Distance[At, J] + (Edge[I, J] - (Distance[At, J] - Distance[At, I])) / 2
          Else
            ThisEdge := Distance[At, I] + (Edge[I, J] - (Distance[At, I] - Distance[At, J])) / 2;
          if ThisEdge > Cur Then Cur := ThisEdge;
        end;
      end;
  BurnAt := Cur;
end;

procedure Solve;
var
  I: Integer;
  Cur: Real;
begin
  Res := Infinity;
  for I := 1 To NG Do
    with Vertex[I] Do
      if not Odd(X) And not Odd(Y) Then begin
        Cur := BurnAt(I);
        if Cur < Res Then begin
          Res := Cur;
          ResX := X Div 2;
          ResY := Y Div 2;
        end;
      end;
end;

procedure Save;
begin
  Assign(F, 'Task3.Out');
  ReWrite(F);
  WriteLn(F, ResX, ' ', ResY);
  WriteLn(F, Res / 2:0:2);
  Close(F);
end;

begin
  Load;
  BuildGraph;
  FindShortestPaths;
  Solve;
  Save;
end.