TSP zu langsam

Heiko · Beiträge: 3169 Erhaltene Danke: 11

Hallo,

wir soll(t)en in der Schule das TSP (Traveling-Salesman-Problem) implementieren. Da es sich dabei um ein NPC-Problem handelt, haben wir eine Optimierung behandelt, die schneller zur Lösung korrekten führt (allerdings weiterhin NPC). Allerdings trinkt man Algo irgendwo zwischendurch Kaffee (eher Schlafmittel, als nen Aufputschmittel

). Die Ursache dafür ist mir leider bis dato unbekannt. Sieht einer von ecuh den?

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:

function TGraph.TSP(var Way: TIntArray): Integer;
const
  CReserveCount = 100;

type
  PTSPData = ^TTSPData;
  TTSPData = record
    MateID: Integer;
    WayLen: Integer;
    next  : PTSPData;
  end;

  PTSPList = ^TTSPList;
  TTSPList = record
    next: PTSPList;
    ID  : integer;
    conn: PTSPData;
  end;

  PWay = ^TWay;
  TWay = record
    next: PWay;
    ID  : integer;
  end;

  PPriorityList = ^TPriorityList;
  TPriorityList = record
    ID    : integer;
    next  : PPriorityList;
    way   : PWay;
    WayLen: Integer;
    MinWay: Integer;
    data  : PTSPList;
  end;

  PMemData = ^TMemData;
  TMemData = record
    next: PMemData;
  end;

var
  i, j               : Integer;
  NodeCnt            : Integer;
  newP, curP         : PPriorityList;
  Priority           : PPriorityList;
  PriorityFree       : PPriorityList;
  tmpLC, tmpLP, tmpPr: PTSPList;
  tmpC,tmpP,newD,
  cur, tmpO          : PTSPData;
  tmpFreeMemPos      : Integer;
  num                : integer;
  childCnts          : array of integer;
  StartNode          : Integer;
  wayC, wayP         : PWay;

  MaxMemSize         : Integer;
  ReserveMemSize     : Integer;
  MemPos             : PMemData;

  procedure GetNewPriorityItems;
  var
    i        : integer;
    oldMemPos: Pointer;
    curData  : PPriorityList;
    prev     : PPriorityList;
  begin
    //Speicher reservieren
    oldMemPos:=MemPos;
    GetMem(MemPos, ReserveMemSize);
    MemPos^.next:=oldMemPos;

    //Speicher zerteilen
    prev:=nil;
    curData:=PPriorityList(Integer(MemPos)+SizeOf(PMemData));
    for i := CReserveCount-1 downto 0 do
    begin
      curData^.next:=prev;
      prev:=curData;
      inc(Integer(curData), MaxMemSize);
    end;
    dec(Integer(curData), MaxMemSize);
    PriorityFree:=curData;
  end;

  procedure FreeAllPriorityItems;
  var
    nextMemPos: PMemData;
  begin
    while MemPos<>nil do
    begin
      nextMemPos:=MemPos^.next;
      FreeMem(MemPos, ReserveMemSize);
      MemPos:=nextMemPos;
    end;
  end;

  //untere schranke ermitteln + leere Elemente entfernen
  procedure WriteMinWayToCurrentPriorityItem(item: PPriorityList);
  begin
    item^.MinWay:=0;
    tmpLC:=item^.data;
    tmpLP:=nil;
    while tmpLC<>nil do
    begin
      if tmpLC^.conn=nil then
      begin
        if tmpLP=nil then item^.data:=tmpLC^.next
        else tmpLP^.next:=tmpLC^.next;
      end
      else
      begin
        inc(item^.MinWay, tmpLC^.conn^.WayLen);
        tmpLP:=tmpLC;
      end;
      tmpLC:=tmpLC^.next;
    end;
    inc(item^.MinWay, item^.WayLen);
  end;

begin
  Result:=-1;
  SetLength(Way, 0);
  if _NodeCount = 0 then exit;
  
  PriorityFree:=nil;
  MemPos:=nil;

  //maximaler Speicherbedarf ermitteln
  MaxMemSize:=SizeOf(TPriorityList);
  SetLength(childCnts, _NodeCount);
  for i := _NodeCount-1 downto 0 do
  begin
    NodeCnt:=0;
    for j := High(_NodesList[i]) downto 0 do
      if TryStrToInt(_NodesList[i][j].Caption, num) and (num>-1) then inc(NodeCnt);
    childCnts[i]:=NodeCnt;
    if NodeCnt>0 then inc(MaxMemSize, SizeOf(TTSPList)+NodeCnt*SizeOf(TTSPData));
  end;
  ReserveMemSize:=MaxMemSize*CReserveCount+SizeOf(PMemData);
  GetNewPriorityItems;

  //erstes Element popen und Startdaten laden
  Priority:=PriorityFree;
  PriorityFree  := PriorityFree^.next;
  Priority.next := nil;
  Priority.way  := nil;
  Priority.ID   := _NodeCount;
  //Daten laden
  Priority.data:=nil;
  tmpFreeMemPos:=Integer(@Priority.data)+SizeOf(PTSPList);
  for i := _NodeCount-1 downto 0 do
  begin
    if childCnts[i]>0 then
    begin
      with Priority^ do
      begin
        tmpLC:=data;
        data:=PTSPList(tmpFreeMemPos);
        ID:=i;
        data^.next:=tmpLC;
        data^.ID:=i;
        data^.conn:=nil;
      end;
      inc(tmpFreeMemPos, SizeOf(TTSPList));
      //Verbindungen
      for j := High(_NodesList[i]) downto 0 do
      begin
        if TryStrToInt(_NodesList[i][j].Caption, num) and (num>-1) then
        begin
          //position zum einfügen suchen
          tmpC:=Priority^.data^.conn;
          tmpP:=nil;
          while (tmpC<>nil) and (tmpC.WayLen<num) do
          begin
            tmpP:=tmpC;
            tmpC:=tmpC^.next;
          end;

          //einfügen
          newD:=PTSPData(tmpFreeMemPos);
          newD^.MateID:=_NodesList[i][j].ID;
          newD^.WayLen:=num;
          newD^.next:=tmpC;
          if tmpP=nil then Priority^.data^.conn:=newD
          else tmpP^.next:=newD;
          inc(tmpFreeMemPos, SizeOf(TTSPData));
        end;
      end;
    end;
  end;
  SetLength(childCnts, 0);
  if Priority^.ID<>_NodeCount then
  begin
    StartNode:=Priority^.ID;
    //Minimalen Weg "berechnen"
    Priority^.WayLen:=0; //reseten
    WriteMinWayToCurrentPriorityItem(Priority);

    //eigentliche TSP starten
    while Priority<>nil  do
    begin
      //Ende erreicht oder weiteres pushen nötig?
      if Priority^.data^.next=nil then //nur noch ein Weg da?
      begin
        if Priority^.data^.conn^.MateID=StartNode then
        begin
          Result:=Priority^.WayLen+Priority^.data^.conn^.WayLen;
          SetLength(Way, _NodeCount);
          Way[_NodeCount - 1]:=Priority^.ID+1;
          for i := _NodeCount - 2 downto 0 do
          begin
            Way[i]:=Priority^.way^.ID+1;
            Priority^.way:=Priority^.way^.next;
          end;
          Priority:=nil;
        end;
      end
      else //pushen
      begin
        //sich selbst löschen
        cur:=nil;
        tmpLP:=nil;
        tmpLC:=Priority^.data;
        while tmpLC<>nil do
        begin
          if tmpLC^.ID=Priority^.ID then
          begin
            cur:=tmpLC^.conn;
            if tmpLP=nil then Priority^.data:=tmpLC^.next
            else tmpLP^.next:=tmpLC^.next;
          end
          else tmpLp:=tmpLC;
          tmpLC:=tmpLC^.next;
        end;
        //neuen pushen
        while cur<>nil do
        begin
          //leeres Priotitäts-Element holen
          if PriorityFree = nil then GetNewPriorityItems;
          newP:=PriorityFree;
          PriorityFree:=PriorityFree^.next;

          //Weg kopieren
          tmpFreeMemPos:=Integer(@newP.data)+SizeOf(PTSPList);
          newP^.way  := PWay(tmpFreeMemPos);
          newP^.way^.ID:=Priority^.ID;
          newP^.way^.next:=nil;
          inc(Integer(tmpFreeMemPos), SizeOf(TWay));
          wayP:=newP^.way;
          wayC:=Priority^.way;
          while wayC<>nil do
          begin
            wayP^.next:=PWay(tmpFreeMemPos);
            wayP^.next^.ID:=wayC^.ID;
            wayP:=wayP^.next;
            wayC:=wayC^.next;
            inc(Integer(tmpFreeMemPos), SizeOf(TWay));
          end;
          wayP^.next:=nil;

          newP^.ID   := cur^.MateID;
          newP^.WayLen:=Priority^.WayLen+cur^.WayLen;
          //Daten kopieren
          newP^.data:=nil;
          tmpPr:=Priority^.data;
          while tmpPr<>nil do
          begin
            with newP^ do
            begin
              tmpLC:=data;
              data:=PTSPList(tmpFreeMemPos);
              ID:=cur^.MateID;
              data^.next:=tmpLC;
              data^.ID:=tmpPr^.ID;
              data^.conn:=nil;
            end;
            inc(tmpFreeMemPos, SizeOf(TTSPList));
            //Verbindungen kopieren
            tmpO:=tmpPr^.conn;
            tmpC:=newP^.data^.conn;
            while tmpO<>nil do
            begin
              if (tmpO^.MateID<>cur^.MateID) and (not ((tmpO^.MateID=Priority^.ID) and (cur^.MateID=tmpPr^.ID))) then
              begin
                //einfügen
                newD:=PTSPData(tmpFreeMemPos);
                newD^.MateID:=tmpO^.MateID;
                newD^.WayLen:=tmpO^.WayLen;
                newD^.next:=nil;
                if tmpC=nil then newP^.data^.conn:=newD
                else tmpC^.next:=newD;
                inc(tmpFreeMemPos, SizeOf(TTSPData));
                tmpC:=newD;
              end;
              tmpO:=tmpO^.next;
            end;
            tmpPr:=tmpPr^.next;
          end;
          WriteMinWayToCurrentPriorityItem(newP);
          if newP^.data<>nil then
          begin
            curP:=Priority;
            while (curP^.next<>nil) and (curP^.next^.MinWay<newP^.MinWay) do curP:=curP^.next;
            newP^.next:=curP^.next;
            curP^.next:=newP;
          end;
          cur:=cur^.next;
        end;
        //aktuelles Prioritätselement freigeben
        curP:=Priority;
        Priority:=Priority^.next;
        curP^.next:=PriorityFree;
        PriorityFree:=curP;
      end;
    end;    
  end
  else
  begin
    if _NodeCount=1 then
    begin
      Result:=0;
      SetLength(Way, 1);
      Way[0]:=0; //einfach den ersten Knoten nehmen
    end;
  end;
  //ganzen Speicher wieder freigeben
  FreeAllPriorityItems;
end;

Zum Algo: Normalerweise wird eine Tiefensuche verwendet. Zur "Abkürzung" nimmt man nun keine Tiefensuche mehr, sondern wählt immer den Weg als nächstes, der am wahrscheinlichsten zur geringsten Lösung führen könnte. Dazu wird bei jedem Schritt ermittelt, was die minimale Kante an den ürbigen Knoten ist + den bereits zurückgelegten Wert. Das ganze hat also eine Prioritätswarteschlange.
Als zusatzliche, Delphi-spezifische, Optimierung habe ich über den Speichermanager einen eigenen "Speichermanager" gelegt, der mit Verschnitt arbeit, aber eben weiß, ohne nachgucken zu müssen, wo noch genug Speicher frei ist.

Von daher weiß ich auf Anhieb nicht, warum mein Algo deutlich langsamer ist, als die einfache Tiefensuche (auf einen vollständigen Graphen mit 10 Knoten braucht meiner 4,7min, während die Tiefensuche 150ms braucht

)

Horst_H · Verfasst: Mi 27.02.08 08:53

Hallo,

soll man jetzt herausfinden, in welcher Ecke das Programm am längsten verweilt?
Dies kannst Du doch selber testen, in dem Du einfach ein paar globale Zaehler in Deine Funktionen einbaust.
Ein vollständiges Programm mit einlesbaren Daten wäre hilfreicher, um es in Delphi selbst zu betrachten, so kann man nichts testen und jeden Gedanken erfassen.Das ist mir heute morgen zu undurchsichtig, wo blebt der Kaffee... ;-)

Also häng mal ein minimales lauffähiges Programmschnipsel mit Daten an.

Gruß Horst
P.S.:
Ein Struktogramm könnte Dir auch die Augen öffnen wo es klemmt oder sich verrennt.

martin_yt · Hält's aus hier Beiträge: 14

Hi

wie mein Vorredner schon andeutete, ist es für uns fast unmöglich herauszufinden, wo das Programm unnötig viel Zeit verbraucht. Aber das kannst du ja auch selbst herausfinden, indem du jede Prozedur einzeln auf Herz und Nieren (und insbesondere auf ihre Laufzeit) untersuchst.

Zu Deinem Algorithmus habe ich selbst aber ein paar Fragen:
Du sagst, normalerweise wird Tiefensuche verwendet: Das ist ja genau genommen nur das Ausprobieren aller Möglichkeiten, brute force, oder irre ich mich?

Zitat:

Zum Algo:
...
wählt immer den Weg als nächstes, der am wahrscheinlichsten zur geringsten Lösung führen könnte. Dazu wird bei jedem Schritt ermittelt, was die minimale Kante an den übrigen Knoten ist + den bereits zurückgelegten Wert.
...

Darf ich fragen, wie du den "Knoten, der am wahrscheinlichsten zur geringsten Lösung führen könnte" ermittelst? Aus deiner Algorithmen-Beschreibung wird mir das nicht ganz klar: nimmst Du einfach von den vom aktuellen Knoten wegführenden Kanten diejenige zum Weg dazu, die die geringsten Kosten hat? So klingts in Deiner Beschreibung fast. Allerdings gehe ich davon aus, dass Du das nicht meinst, denn dieser "greedy" Algorithmus führt nicht immer zur korrekten Lösung, was du eingangs sagtest.
Erklär ihn mir doch bitte nochmal. Oder führe ihn vielleicht an einem kleinen Beispiel aus.
(sorry, aus dem Code werde ich einfach nicht schlau, da helfen mir auch die gutgemeinten Kommentare nicht ;-)

)

Zitat:

Von daher weiß ich auf Anhieb nicht, warum mein Algo deutlich langsamer ist, als die einfache Tiefensuche (auf einen vollständigen Graphen mit 10 Knoten braucht meiner 4,7min, während die Tiefensuche 150ms braucht

)

Hast du die normale Tiefensuche auch implementiert? Woher hast du die 150ms für den Graphen mit 10 Knoten? Das wäre nämlich eine Spitzenzeit für 10 Knoten!
Ich hab vor geraumer Zeit selbst vier Algorithmen (BruteForce, dynamische Programmierung, einen gierigen Algoritmus und eine randomiesiete Suche) in Octave (/Matlab) implementiert und solch eine Zeit ist fast schon utopisch für 10 Knoten, sofern Du wirklich immer die kürzesten Rundreisen findest!

Zum Schluß verweise ich noch auf einen Artikel, der Dich sicher auch interessieren könnte: www-i1.informatik.rw...gorithmus/algo40.php

Gruß,
martin

Horst_H · Verfasst: Mi 27.02.08 17:31

Hallo,

die Geschwindigkeit hängt ja auch vom Rechner ab.
Mittels eines Abständefeldes 10x10 , die nur auf der Diagonalen mit 1e300 belegt, sonst mit Zufallszahlen aus ]0,100[
war das Finden meist in etwa 0.13 Sekunden erledigt (2.3 Ghz AMDX2).
Üblicherweise ist der Weg von A nach B gleich dem von B nach A, aber das habe ich weggelassen. Das heisst 0,15 Sekunden sind für den Brute Force Ansatz plausibel.

Gruß Horst
P.S.:
Ich hoffe, ich habe das jetzt nicht falsch gepinselt. Jetzt ohne Random, sodass erst weit noch unten gesucht werden muss.
Das sind jetzt 0.05 s (Cool&Quite sollte man schon abschalten ;-)

)

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:

program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils;
const
  MAX = 10;
  MAX_1 = MAX-1;
type

  tINdex = 0..MAX;

  tIndexArray = array[tINdex] of tIndex;
  tCheckArray = array[tIndex,tIndex] of double;

var
  t,t0,t1:TdateTime;
  CheckArray : tCheckArray;
  MomMinIndex,
  AbgearbeitetIndex : tIndexArray;
  Wegstrecke,
  momMinWeg : double;
  sp,ze,i: integer;


function NextPermut(var a:tIndexArray;n:integer): Boolean;
{Naechste Permuttino bis zum n-ten Zeichen}
var
   k,j,r,s : integer;
   temp    : integer;
   procedure swap(i,j :integer);
   begin
     temp := a[i];
     a[i] := a[j];
     a[j] := temp;
   end;

begin
   k := n-1;
   while  (k>0)  AND(a[k] > a[k+1]) do
      k:=k-1;
   if k >0 then
   begin
      j := n;
      while a[k] > a[j] do
          j:=j-1;
      swap(j,k);
      r:=n;
      s:=k+1;
      while r>s do
      begin
         swap(r,s);
         r:=r-1;
         s:=s+1;
      end;
      NextPermut:= true;
   end
   else
   {Reverse order reached -> end}
      NextPermut := false
end;

begin
  randseed := 147110815;
  For ze := 1 to Max Do
     For sp := 1 to Max do
       If sp <> ze then
         //CheckArray[ze,sp] := random*100.0
         CheckArray[ze,sp] := (MAX-sp+1)*(MAX-ze+1)
       else
         CheckArray[ze,sp] := 1e300;

   For sp := 1 to Max-1 do
     AbgearbeitetIndex[sp] := sp+1;
   AbgearbeitetIndex[MAX] := 1;
   // dort steht der Weg drin 
   // Satrt automatisch bei 1 und dann 2,3,4,5,...MAX, 1 drin
   
   MomMinWeg := 1e299;
   t0 := time;

   repeat
     WegStrecke :=0.0;
     ze := 1; // Starte in Stadt 1
     for i := 1 to MAX do
       begin
       Wegstrecke := Wegstrecke+CheckArray[ze,AbgearbeitetIndex[i]];
       //Unnötige Wege nicht weiter verfolgen
       if WegStrecke > MomMinWeg then
         break;
       ze := AbgearbeitetIndex[i]
       end;
       // Neuen Weg speichern
       IF Wegstrecke < momMinWeg then
         begin
          MomMinWeg :=WegStrecke;
          MomMinIndex:=AbgearbeitetIndex;
         end;
   until NOT(NextPermut(AbgearbeitetIndex,Max_1));
   // Nach Test von allen Wegen, muss der kürzeste wohl dabei sein
   writeln(MomMinWeg:10:5);
   ze := 1; // Starte in Stadt 1
   for i := 1 to MAX do
     begin
     writeln(ze:2,' -> ',MomMinIndex[i]:2,CheckArray[ze,MomMinIndex[i]]:10:4);
     ze := MomMinIndex[i];
     end;

   writeln(FormatdateTime('  hh:mm:ss.zzz',time-t0))  ;
  readln;
end.

Heiko · Beiträge: 3169 Erhaltene Danke: 11

Horst_H hat folgendes geschrieben:

soll man jetzt herausfinden, in welcher Ecke das Programm am längsten verweilt?

Ja

. Das es beim abarbeiten der Prioritätswarteschlange ist, ist klar. Aber wo genau nicht (ich vermute beim Kopieren für die neuen Prioritätswarteschlangen). Mein Problem ist, bei 4 Städten hat mein Algo ne Geschwindigkeit von ca. 0,6ms.
Ich bin momentan dabei mit nem Profiler das auseinanderzunehmen, aber dazu muss ich den Code weiter zerlegen, da man keine Zwischenpunkte Zeitmesspunkte setzten kann

.

Horst_H hat folgendes geschrieben:

Ein Struktogramm könnte Dir auch die Augen öffnen wo es klemmt oder sich verrennt.

Ich vermute mal, dass es nicht daran liegt. Denn den Algo habe ich lang genug durch den Kopf gewälzt, bevor ich mich für die herangehensweise entschieden habe

.