Das Travelling-Salesman-Problem (TSP)

• Gesucht wird in einem Graphen der kürzeste Weg, der von einem Knoten zu einem anderen Knoten führt und alle anderen Knoten mindestens einmal besucht. Im Original ist der Endknoten gleich dem Startknoten und jeder Knoten muß genau einmal besucht werden. Dies ist eine Einschränkung, die dazu führt, daß es in vielen Fällen überhaupt keine Lösung gibt.
• Ein Handlungsreisender stellt fest, in welchen Städten er Kunden besuchen muß und versucht eine Route zu finden, die möglichst kurz ist. Im Allgemeinem ist dieses Problem in allen ähnlichen Aufgabenstellungen enthalten, bei denen es um Tourenplanung geht; es ist also ständig von Handlungsreisenden, Speditionen, etc. zu lösen.
• Zur Lösung des TSPs generieren wir alle möglichen Wege, die alle Städte besuchen und jede höchsten AriMax mal. Zur Generierung aller Wege können wir einen Algorithmus verwenden, der Ähnlichkeit mit der Tiefensuche hat, wir müssen bloß die Knoten eines Graphen derart aufzählen, daß dabei ein Weg entsteht. Wenn man in eine Sackgasse gerät, kann man dies durch Rücksetzen der gemachten Besuche erreichen. Der kürzeste Weg wird gespeichert und nach durchlaufen aller möglichen Wege steht der kürzeste Weg im Speicher zur Verfügung.

.
Algorithmus:

TSP(StartIndex, EndIndex: IndexType; var Distance :Real; AriMax: Integer);
var      Schranke, AktWegLaenge    :Real;
         WegeMax                   :IndexType;
type     TMinEntfs = array[KnotenAnzahl] of IndexType;
var      MinWeg                    :TMinEntf;

 Besuche(k: IndexType; var Weg :TMinEntfs; maxIndex: IndexType);
 var    BisherigeLaenge        :Real;
        Knoten                 :PKnoten;
        n                      :IndexType;
 begin
   inc(maxIndex)
   Weg[maxIndex] = k
   if erster Durchlauf then
     AktWegLaenge = 0
     BisherigeLaenge = 0
   else
     BisherigeLaenge = AktWegLaenge
     AktWegLaenge = AktWegLaenge + Kantenwert(k, Weg[maxIndex-1])
   end-if
   inc(Marke(k))
   if AktWegLaenge < Schranke then
     if ist_eine_TSP-Lösung then
       MinWeg = Weg
       Schranke = AktWegLaenge
     else
       for-each x in (Kante von Knoten(k)) do
         if Marke(Kante(k, x).ZielKnoten) < AriMax then
          Besuche(Kante(k, x).ZielKnoten, Weg, maxIndex)
         end-if
       end-for-each
     end-if
   end-if
   AktWegLaenge = BisherigeLaenge
   Weg[maxIndex] = 0
   dec(Marke(k))
 end


var      Weg                    :TMinEntfs;
         KnotenNr, WegIndex, n  :IndexType;
begin
  WegeMax = AriMax * FCount + 3
  KantenCount = 0
  Schranke = 0
  for-each x in Kanten do
    Schranke := Schranke + x.Wert
  end-for-each
  for n = 1 to KnotenAnzahl do
    Weg(n) = 0
    MinWeg(n) = 0
    Marken(n) = 0
  end-for
  Besuche(StartIndex, Weg, 0)
  Distance = Schranke
end

.
Beispielrealisierung (in gekürzter Fassung):

function TGraph.TravellingSalesmanProblem(StartIndex, EndIndex: IndexType;
    var KantenCount: IndexType; var Distance :Real; AriMax: Integer): Boolean;
var      Schranke             :Real;
         HatWeg               :Boolean;
         WegeMax              :IndexType;
         AktWegLaenge         :Real;
type     TMinEntfs = array[1..1] of IndexType;
var      MinWeg               :^TMinEntfs;

 function TesteWeg(var Weg :TMinEntfs; maxIndex: IndexType): Boolean;
 var      k       :IndexType;
 begin                // über alle Knoten den Zielknoten erreicht?
  Result := (Weg[maxIndex] = EndIndex) and (maxIndex > FCount-1);
  k := 1;
  while (k <= FCount) and Result do
   begin
    Result := PointItem(k).Marke <> 0;
    inc(k);
   end;
 end;

 procedure Besuche(k: IndexType; var Weg :TMinEntfs; maxIndex: IndexType);
 var       BisherigeLaenge     :Real;
           Knoten              :PKnoten;
           n                   :IndexType;
 begin
  inc(maxIndex);
  if maxIndex >= WegeMax-2 then
   raise Exception.Create('Der Weg wurde zu lang ...');
  Weg[maxIndex] := k;
  if maxIndex = 1 then // allererster Aufruf?
   begin
    AktWegLaenge := 0;
    BisherigeLaenge := 0;
   end
  else
   begin
    BisherigeLaenge := AktWegLaenge;
    Knoten := PointItem(Weg[maxIndex-1]);
    if Knoten.KantenCount > 0 then // inc(AktWegLaenge, Kantenwert)
     for n := 0 to Knoten.KantenCount-1 do
      if Knoten.Kanten[n].DestKnoten = k then
       AktWegLaenge := AktWegLaenge + Knoten.Kanten[n].Value;
   end;

  Knoten := PointItem(k);
  inc(Knoten.Marke);
  if AktWegLaenge < Schranke then // bereits gegangener Weg innerhalb Grenze?
   if TesteWeg(Weg, maxIndex) then // Ziel bereits erreicht?
    begin                         // Aktuellen Weg umkopieren
     Move(Weg, MinWeg^, (maxIndex+1) * SizeOf(Weg[1]));
     Schranke := AktWegLaenge;
     HatWeg := True;
    end
   else                             // Besuche jeden Nachbarknoten
    if Knoten.KantenCount > 0 then
     for n := 0 to Knoten.KantenCount-1 do
      if PointItem(Knoten.Kanten[n].DestKnoten).Marke < AriMax then
       Besuche(Knoten.Kanten[n].DestKnoten, Weg, maxIndex);
  AktWegLaenge := BisherigeLaenge;     // die Rekursion rückgängig machen
  Weg[maxIndex] := 0;
  dec(PointItem(k).Marke);
 end;

 procedure CalculateSchranke;
 var       Counter, n     :IndexType;
 begin            // Summe der Gewichtung sämtlicher Kanten
  Schranke := 0;
  if FStart <> nil then
   for Counter := 1 to FCount do
    with PointItem(i)^ do
     if KantenCount > 0 then
      for n := 0 to KantenCount - 1 do
       Schranke := Schranke + Kanten[n].Value;
end;

var      Weg                      :^TMinEntfs;
         KnotenNr, WegIndex, n    :IndexType;
         Knoten                   :PKnoten;
begin
 WegeMax := AriMax * FCount + 3;
 KantenCount := 0;
 Distance := 0;
 GetMem(MinWeg, sizeof(MinWeg[1]) * WegeMax);
 try
   CalculateSchranke;
   GetMem(Weg, sizeof(Weg[1]) * WegeMax);
   try
     FillChar(Weg^, sizeof(Weg[1]) * WegeMax, 0);
     FillChar(MinWeg^, sizeof(MinWeg[1]) * WegeMax, 0);
     ZeroKnotenMarken;
     HatWeg := False;
     Besuche(StartIndex, Weg^, 0); // starten der Rekursion
     KantenCount := 0;
     ZeroKnotenMarken;
     ZeroKantenMarken;
     if HatWeg then // markieren des Weges
      begin
       KnotenNr := MinWeg[1];
       WegIndex := 2;
       Knoten := nil;
       while KnotenNr >= 1 do
        begin
         if assigned(Knoten) then
          begin
           if Knoten.KantenCount > 0 then
            for n := 0 to Knoten.KantenCount-1 do
             if Knoten.Kanten[n].DestKnoten = KnotenNr then
              inc(Knoten.Kanten[n].Marke);
           inc(Knoten.Marke);
          end;
         Knoten := PointItem(KnotenNr);
         KnotenNr := MinWeg[WegIndex];
         inc(WegIndex);
         inc(KantenCount);
        end;
       if assigned(Knoten) then
        inc(Knoten.Marke);
       Distance := Schranke;
      end;
   finally
    FreeMem(Weg, sizeof(Weg[1]) * WegeMax);
   end;
 finally
  FreeMem(MinWeg, sizeof(MinWeg[1]) * WegeMax);
 end;
 Result := HatWeg;
end;

.
Effizienzbetrachtung: