Problem trgovskega potnika/Implementacija (Mathematica)

Iz MaFiRaWiki

Ideja

Reševanje problema trgovskega potnika z metodo razveji in omeji poteka tako, da najprej najdemo neko rešitev problema, nato pa gremo nazaj in na vsakem koraku opustimo vse poti, ki nas ne morejo pripeljati do boljše rešitve, kot jo že imamo. Tu se pojavi dilema: če hočemo izračunati obetavnost neke poti v Mathematici, moramo narediti nek izračun, ki pa nam vzame vsaj toliko časa, kot če bi izračunali stroške cele poti do cilja. (Izkazalo se je, da je klasično računanje obetavnosti s pomočjo redukcije matrik, mnogo zamudnejše, kot izračun cene poti do cilja s permutacijami.)

(Opomba: Govorimo o problemu do približno 10 mest, ker Mathematica počasi računa že s permutacijami 10-ih elemntov, ob problemu večjih dimenzij pa nam bo verjetno javila napako "pomanjkanje spomina".)

Ta algoritem zato ubere nekoliko drugačno pot: na vsakem koraku bomo izračunavali samo tisto, kar nas lahko vodi do boljše poti. Namesto, da bi na vsakem koraku izračunali obetavnost poti, bomo upoštevali ceno, že do zdaj prehojene poti. Namreč, prva pot, ki jo prehodimo do cilja, je izbrana na podlagi najnižjih stroškov na vsakem koraku. Na začetku sestavimo tabelo permutacij n-2 elementov, kjer je n število mest. Ker delamo krožno pot, je vseeno v katerem mestu začnemo, zato bo to mesto vedno 1. Predpostavili bomo tudi, da gremo v vsako mesto le enkrat. (To je primer PTP za razdalje med mesti v evklidskem prostoru, kjer trikotniška neenakost zagotavlja, da je pot med dvema mestoma daljša, če gremo preko tretjega mesta, ali kvečjemu enaka, kakor pa direktna pot.) Pot med recimo petimi mesti je natanko določena s trojico 1-3-4, kar pomeni, da naredimo krožno pot 1-3-4-2-1.

Algoritem najprej izračuna vse cene poti 1-i in med njimi izbere najcenejšo. Potem izračuna vse cene poti 1-najcen-j in spet izbere najcenejšo itn. dokler ne pride do prve rešitve. Nato stopi korak nazaj in tam oklesti vse poti, ki so že zdaj dražje od rešitve. Tako se naša množica poti, ki jih moramo pregledati, zmanjša. (Algoritem postavi njihove vrednosti na Null.) Sama množica poti, ki jih še moramo pregledati je generirana tako, da so poti urejene od do-zdaj-najcenejše poti do najdražje. S tem je poskrbljeno, da čim več poti že zdaj dražjih od trenutno najboljše rešite postavimo na Null in jih algoritem obide, ko prispe do njih. To je v algoritmu omogočeno z dodatnimi funkcijami, ki so definirane na začetku.


Algoritem

M je primer omrežne matrike dimenzije 5. V algoritmu je dimenzija problema (število mest) omejena z abecedo na 8, lahko pa jo poljubno razširimo na n mest, tako da dodamo črke v abecedo. (Kar pa ni smiselno, saj bi za izračun v Mathematici porabili preveč časa.)

M = {{∞, 20, 30, 10, 11}, {15, ∞, 16, 4, 2}, {3, 5, 
      ∞, 2, 4}, {19, 6, 180, ∞, 3}, {16, 4, 7, 16, ∞}};

Dim = First[Dimensions[M]];
$RecursionLimit = Infinity;
$IterationLimit = Infinity;
VsePermutaije = Permutations[Table[i, {i, 2, Dim}]];
abeceda := If[Dim == 8,
      Flatten[Table[{a, b, c, d, e, 
    f}, {a, 7}, {b, 6}, {c, 5}, {d, 4}, {e, 3}, {f, 2}], 5],
      If[Dim == 7,
        Flatten[Table[{
    b, c, d, e, f}, {b, 6}, {c, 5}, {d, 4}, {e, 3}, {f, 2}], 4],
        If[Dim == 6,
          Flatten[Table[{c, d, e, f}, {c, 5}, {d, 4}, {e, 3}, {f, 2}], 3],
          If[Dim == 5,
            Flatten[Table[{d, e, f}, {d, 4}, {e, 3}, {f, 2}], 2],
            If[Dim == 4,
              Flatten[Table[{e, f}, {e, 3}, {f, 2}], 1]
              ]
            ]
          ]
        ]
      ];
Cena[i_, j_] := Cena[{i, j}];
Cena[{i_, j_}] := Cena[{i, j}] = M[[i]][[j]];
Cena[x___] := Cena[{x}];
Cena[{x___}] := Cena[{x}] = Cena[Take[{x}, Length[{x}] - 1]] + M[[Take[{x},
               Length[{x}] - 1][[-1]]]][[{x}[[-1]]]];
VseCene[{0}] := VseCene[0];
VseCene[0] = Table[{{1, i}, Cena[1, i]}, {i, 2, Dim}];
NajCena[{n_}] := NajCena[n];
NajCena[n_] := VseCene[0][[Ordering[VseCene[0][[All, 2]], Dim - 1][[n]]]];
VseCene[{n_}] := VseCene[n];
VseCene[n_] := DeleteCases[
      Table[
        If[MemberQ[NajCena[n][[1]], i] == False,
          {Join[NajCena[n][[1]], {i}], Cena[Join[NajCena[
    n][[1]], {i}]]}, Null
          ],
        {i, 2, Dim}]
      , Null];
NajCena[{1, n_}] := NajCena[1, n];
NajCena[1, n_] := VseCene[1][[Ordering[VseCene[1][[All, 2]], Dim - 2][[n]]]];
NajCena[{m_, n_}] := NajCena[m, n];
NajCena[m_, n_] := VseCene[m][[Ordering[VseCene[m][[All, 2]],
                 Dim - 2][[n]]]];
VseCene[{1, 1}] := VseCene[1, 1];
VseCene[1, 1] := DeleteCases[
      Table[
        If[MemberQ[NajCena[1, 1][[1]], i] == False,
          {Join[NajCena[1, 1][[1]], {i}], Cena[Join[
NajCena[1, 1][[1]], {i}]]}, Null
          ],
        {i, 2, Dim}]
      , Null];
VseCene[{1, n_}] := VseCene[1, n];
VseCene[1, n_] := DeleteCases[
      Table[
        If[MemberQ[NajCena[1, n][[1]], i] == False,
          {Join[NajCena[
      1, n][[1]], {i}], Cena[Join[NajCena[1, n][[1]], {i}]]}, Null
          ],
        {i, 2, Dim}]
      , Null];
VseCene[{m_, n_}] := VseCene[m, n];
VseCene[m_, n_] := VseCene[m, n] = DeleteCases[
        Table[
          If[MemberQ[NajCena[m, n][[1]], i] == False,
            {Join[NajCena[m, n][[1]], {i}], Cena[
    Join[NajCena[m, n][[1]], {i}]]}, Null
            ],
          {i, 2, Dim}]
        , Null];
NajCena[m_, n_, x___] := NajCena[{m, n, x}];
NajCena[{m_, n_, x___}] := VseCene[Delete[{m, n, x}, -1]][[Ordering[VseCene[
            Delete[{m,
             n, x}, -1]][[All, 2]], Length[VseCene[Delete[{m, n,
                 x}, -1]]]][[{m, n, x}[[-1]]]]]];
VseCene[m_, n_, x___] := VseCene[{m, n, x}];
VseCene[{m_, n_, x___}] := DeleteCases[
      Table[
        If[MemberQ[NajCena[m, n, x][[1]], i] == False,
          {Join[NajCena[m, n, 
      x][[1]], {i}], Cena[Join[NajCena[m, n, x][[1]], {i}]]}, Null
          ],
        {i, 2, Dim}]
      , Null];
KoncnaPot[{m_, n_, x___}] := KoncnaPot[m, n, x];
KoncnaPot[m_, n_, x___] := KoncnaPot[m, n, x] =
      DeleteCases[
          Table[
            If[
              (MemberQ[
                    NajCena[m, n, x][[1]], i] == False),
              {Join[NajCena[m, n, x][[1]], {i}, {1}], 
                    NajCena[m, n, x][[-1]] + M[[NajCena[m, n, x][[
                    1]][[-1]]]][[i]] + M[[i]][[1]]}
              ]
            , {i, Dim}], Null][[1]];

Zdaj imamo definirane vse funkcije, ki jih potrebujemo - nekatere so razpisane tako, da pohitrimo delovanje algoritma. V nadaljevanju bomo postavili še navodila, kako se naj algoritem ravna v množici najobetavnejši rešitev in katere poti naj zavrže. Na začetku postavimo še trenutno najboljšo pot, tj. TreNaJ, na . Pozneje jo bomo na vsakem koraku sproti izboljševali in nosili s seboj v množici rešitev Moznosti[.], tako da TreNaj na bo več potrebna. Množica vseh obetavnih poti na n-tem koraku je Moznosti[n]. Slabše poti v tej množici postavljamo na Null. V največ (Dim-2)! korakih, moramo priti do rešitve, tj. sprazniti množico obetavnih rešitev.

TreNaj = ∞;
Moznosti[0] = {abeceda, TreNaj};
Moznosti[1] := Moznosti[1] =
      ReplacePart[
        Delete[Moznosti[0], {1, 1}],
        If[KoncnaPot[Moznosti[0][[1]][[1]]][[-1]] < TreNaj,KoncnaPot[Moznosti[0][[1]][[1]]],TreNaj], -1];
Moznosti[2] := Moznosti[2] =
      ReplacePart[
        Delete[Moznosti[1], {1, 1}],
        If[KoncnaPot[Moznosti[1][[1]][[1]]][[-1]] < Moznosti[1][[-1]][[-1]],
          KoncnaPot[Moznosti[1][[1]][[1]]],
          Moznosti[1][[-1]]
          ]
        , -1];
f[1, {x___}, li_, j_] := ReplacePart[li, j, {1, {x}[[1]]}];
f[2, {x___}, li_, j_] := ReplacePart[f[1, {x}, li, j], j, {1, {x}[[2]]}];
f[i_, {x___}, li_, j_] := ReplacePart[f[
    i - 1, {x}, li, j], j, {1, {x}[[i]]}];
PravaZam[{x___}, li_, j_] := f[Length[{x}], {x}, li, j];
Moznosti[3] := Moznosti[3] =
      If[
NajCena[Delete[Moznosti[2][[1]][[1]], -1]][[-1]] ≥ Moznosti[2][[-1]][[-1]],
        {Delete[PravaZam[Flatten[
    Position[Moznosti[2][[1]][[All, Range[Dim - 3]]],
       Delete[Moznosti[2][[1]][[1]], -1]], 1], Moznosti[2], Null], {1, 1}],
Moznosti[2][[-1]]},
ReplacePart[
Delete[Moznosti[2], {1, 1}],
          If[KoncnaPot[Moznosti[2][[1]][[1]]][[-1]] < Moznosti[2][[-1]][[-1]],

            KoncnaPot[Moznosti[2][[1]][[1]]],
            Moznosti[2][[-1]]
            ],
          -1
]
        ];
Moznosti[n_] := Moznosti[n] =
      If[Moznosti[n - 1][[1]][[1]] =!= Null,
        If[
NajCena[Delete[Moznosti[n - 1][[1]][[1]], -1]][[-1]] ≥ Moznosti[
            n - 1][[-1]][[-1]],
Delete[PravaZam[Flatten[
          Position[Moznosti[n - 1][[1]][[All, Range[Dim - 3]]], Delete[
          Moznosti[n - 1][[
          1]][[1]], -1]], 1], Moznosti[n - 1], Null], {1, 1}],
ReplacePart[
Delete[Moznosti[n - 1], {1, 1}],
            If[KoncnaPot[Moznosti[n - 1][[
            1]][[1]]][[-1]] < Moznosti[n - 1][[-1]][[-1]],
              KoncnaPot[Moznosti[n - 1][[1]][[1]]],
              Moznosti[n - 1][[-1]]
              ], -1]],
Delete[Moznosti[n - 1], {1, 1}],
        ];
OptimalnaPot = Moznosti[(Dim - 1)! - 1][[-1]];
OptimalnaPot

Končno rešitev dobimo z ukazom OptimalnaPot.

(Opozorilo: pred vsakim izračunom je potrebno resetirati kernel.)

Za konkreten M definiran na začetku je rešitev taka:

OptimalnaPot
{{1, 4, 2, 5, 3, 1}, 28}
Osebna orodja