124 lines
2.9 KiB
Plaintext
124 lines
2.9 KiB
Plaintext
(* Transportation Problem Solver using Vogel's Approximation Method *)
|
|
|
|
costs = <|
|
|
"W" -> <|"A" -> 16, "B" -> 16, "C" -> 13, "D" -> 22, "E" -> 17|>,
|
|
"X" -> <|"A" -> 14, "B" -> 14, "C" -> 13, "D" -> 19, "E" -> 15|>,
|
|
"Y" -> <|"A" -> 19, "B" -> 19, "C" -> 20, "D" -> 23, "E" -> 50|>,
|
|
"Z" -> <|"A" -> 50, "B" -> 12, "C" -> 50, "D" -> 15, "E" -> 11|>
|
|
|>;
|
|
|
|
demand = <|"A" -> 30, "B" -> 20, "C" -> 70, "D" -> 30, "E" -> 60|>;
|
|
cols = Sort[Keys[demand]];
|
|
supply = <|"W" -> 50, "X" -> 60, "Y" -> 50, "Z" -> 50|>;
|
|
|
|
(* Initialize result matrix *)
|
|
res = AssociationMap[
|
|
Function[k, AssociationMap[0 &, Keys[demand]]],
|
|
Keys[costs]
|
|
];
|
|
|
|
(* Initialize g dictionary for sorting *)
|
|
g = <||>;
|
|
|
|
(* Sort destinations by cost for each supplier *)
|
|
Do[
|
|
g[x] = SortBy[Keys[costs[x]], costs[x][#] &];
|
|
, {x, Keys[supply]}
|
|
];
|
|
|
|
(* Sort suppliers by cost for each destination *)
|
|
Do[
|
|
g[x] = SortBy[Keys[costs], costs[#][x] &];
|
|
, {x, Keys[demand]}
|
|
];
|
|
|
|
(* Main algorithm loop *)
|
|
While[Length[g] > 0,
|
|
(* Calculate penalties for demand nodes *)
|
|
d = <||>;
|
|
Do[
|
|
If[KeyExistsQ[demand, x] && Length[g[x]] > 0,
|
|
d[x] = If[Length[g[x]] > 1,
|
|
costs[g[x][[2]]][x] - costs[g[x][[1]]][x],
|
|
costs[g[x][[1]]][x]
|
|
];
|
|
];
|
|
, {x, Keys[demand]}
|
|
];
|
|
|
|
(* Calculate penalties for supply nodes *)
|
|
s = <||>;
|
|
Do[
|
|
If[KeyExistsQ[supply, x] && Length[g[x]] > 0,
|
|
s[x] = If[Length[g[x]] > 1,
|
|
costs[x][g[x][[2]]] - costs[x][g[x][[1]]],
|
|
costs[x][g[x][[1]]]
|
|
];
|
|
];
|
|
, {x, Keys[supply]}
|
|
];
|
|
|
|
(* Find keys with maximum penalties *)
|
|
fKey = If[Length[d] > 0,
|
|
First[Keys[d] // SortBy[d[#] &] // Reverse],
|
|
""
|
|
];
|
|
tKey = If[Length[s] > 0,
|
|
First[Keys[s] // SortBy[s[#] &] // Reverse],
|
|
""
|
|
];
|
|
|
|
(* Get the actual maximum values *)
|
|
maxD = If[Length[d] > 0, d[fKey], 0];
|
|
maxS = If[Length[s] > 0, s[tKey], 0];
|
|
|
|
(* Choose the allocation with higher penalty *)
|
|
{t, f} = If[maxD > maxS,
|
|
{fKey, g[fKey][[1]]},
|
|
{g[tKey][[1]], tKey}
|
|
];
|
|
|
|
(* Allocate minimum of supply and demand *)
|
|
v = Min[supply[f], demand[t]];
|
|
res[f][t] += v;
|
|
demand[t] -= v;
|
|
|
|
(* Update demand and remove if satisfied *)
|
|
If[demand[t] == 0,
|
|
Do[
|
|
If[KeyExistsQ[supply, k] && supply[k] != 0,
|
|
g[k] = DeleteCases[g[k], t]
|
|
];
|
|
, {k, Keys[supply]}
|
|
];
|
|
g = KeyDrop[g, t];
|
|
demand = KeyDrop[demand, t];
|
|
];
|
|
|
|
(* Update supply and remove if exhausted *)
|
|
supply[f] -= v;
|
|
If[supply[f] == 0,
|
|
Do[
|
|
If[KeyExistsQ[demand, k] && demand[k] != 0,
|
|
g[k] = DeleteCases[g[k], f]
|
|
];
|
|
, {k, Keys[demand]}
|
|
];
|
|
g = KeyDrop[g, f];
|
|
supply = KeyDrop[supply, f];
|
|
];
|
|
];
|
|
|
|
(*Display results*)
|
|
Print["Transportation Solution:"];
|
|
|
|
Dataset[res]
|
|
|
|
totalCost = 0;
|
|
Do[rowData = Table[
|
|
totalCost += res[supplier][dest]*costs[supplier][dest];
|
|
, {dest, cols}];
|
|
, {supplier, Sort[Keys[costs]]}];
|
|
|
|
Print["Total Cost = ", totalCost];
|