Mathematica code for the Directed Chinese Postman Problem

Harold Thimbleby,
UCLIC, UCL Interaction Centre
LONDON
h.thimbleby@ucl.ac.uk

A graph is a list of edges {from,to,weight,name}. Vertices are numbered 1..N. (In Java, vertices are numbered 0..N-1.)

\(\(ChinesePostman::"usage" = 
\ \ "ChinesePostman[edges] finds an optimal Chinese postman tour of a weighted directed graph with list of edges, edges being of the form {from,to,weight,name}. Vertices (from,to) are natural numbers; weights are reals; and names are any Mathematica objects.";\)\)

We define selectors to extract components of edges. Thus e·weight is the weight of an edge e; this approach gives us a notation similar to Pascal or Java.

{from_, _, _, _}·from = from;
{_, to_, _, _}·to = to;
{_, _, weight_, _}·weight = 
        weight;
{_, _, _, name_}·name = name;
{from_, to_, _, _}·edge = {from, to};

We use a built-in Mathematica linear programming routine. Readability of the program is improved by defining selectors to work with Mathematica's results. (The semantics are that Mathematica finds a solution as a set of forms, such as f[2,3]->5. The selectors extract the appropriate parts of the form.) Mathematica allows us to overload the selectors, so we can reuse the same names for readability.

(f[from_, _] -> _)·from = 
        from;
(f[_, to_] -> _)·to = 
        to;
(f[from_, to_] -> _)·edge = {from, 
          to};
(_ -> count_)·count = count;

Now the code to do the work. (Some ideas for code is available in Combinatorica (a standard Mathematica package) but Combinatorica does not handle multigraphs.)

\(\(ChinesePostman[edges_] := 
        Module[
{c, defined, δ, extraPaths, i, j, k, 
            n, path, cheapest}, 

If[
            edges == {}, 
            Throw["graph is empty"]]; 

 (*\ initialisation\ *) 
n = 
            Max[Map[\((#·edge)\) &, 
                edges]]; 
c = 
            Table[0, {n}, {n}]; 
δ = 
            Table[0, {n}]; 
defined = 
            Table[False, {n}, {n}]; 
cheapest = 
            Table[{}, {n}, {n}]; 
path = 
            Table[{}, {n}, {n}]; 

 (*\ 
            build\ least - 
              cost\ adjacency\ matrix\ *) 
 (*\ 
            and\ calculate\ vertex\ degrees\ *) 
For[i = 1, 
            i ≤ 
              Length[edges], \(i++\), 
Module[
{u = 
                  edges[[i]]·
                    from, v = 
                  edges[[i]]·
                    to, 
w = 
                  edges[[i]]·
                    weight}, 
\(δ[[
                  u]]++\); \ \(δ[[
                  v]]--\); 
If[\(! defined[[u, v]]\) || 
                  w < c[[u, 
                      v]], 
defined[[u, v]] = 
                  True; 
cheapest[[u, 
                    v]] = 
                  edges[[i]]·
                    name; 
c[[u, 
                    v]] = 
                  w; 
\(path[[u, 
                      v]] = 
                    edges[[
                      i]];\)
]
]
]; 

 (*\ 
            build\ paths\ and\ spanning\ tree\ *) 
For[
            k = 1, k ≤ n, \(k++\), 
For[i = 1, 
              i ≤ n, \(i++\), 
If[
                defined[[i, 
                  k]], 
For[j = 1, 
                  j ≤ n, \(j++\), 
If[
                    defined[[k, 
                      j]], 
If[\(! defined[[i, j]]\) || 
                        c[[i, j]] > 
                          c[[i, k]] + 
                            c[[k, 
                              j]], 
c[[i, j]] = 
                        c[[i, k]] + 
                          c[[k, 
                            j]]; 
defined[[i, j]] = 
                        True; 
path[[i, 
                          j]] = 
                        path[[i, 
                          k]];
]
]
]
]
]
]; 

 (*\ check\ graph\ *) 
For[i = 1, 
            i ≤ n, \(i++\), 
If[
              c[[i, i]] < 0, 
              Throw["negative cycles"], 
For[j = 1, 
                j ≤ 
                  n, \(j++\), 
If[\(! defined[[i, 
                      j]]\), 
Throw["not strongly connected"]
]
]
]
]; 

 (*\ 
            construct\ linear\ programming\ problem\ *) 
Module[
{neg, pos, variables, ϕ, 
              constraints}, 
neg = 
              Flatten@Position[δ, _?
                    Negative]; 
pos = 
              Flatten@Position[δ, _?
                    Positive]; 
variables = 
              Flatten@Outer[f, neg, 
                  pos]; 

 (*\ 
              the\ objective\ function\ *) 
ϕ = 
              Plus @@ Flatten@
                  Outer[
Function[{a, b}, 
                      c[[a, b]]*
                        f[a, b]], neg, 
                    pos]; 

 (*\ 
              the\ constraints\ *) 
constraints = 
              Join[
Table[
Plus @@ \(\((f[#1, pos[[i]]] &)\) /@ 
                        neg\) == δ[[pos[[i]]]], 
{i, 
                    Length[pos]}], 
Table[
Plus @@ \(\((f[
                              neg[[i]], #1] &)\) /@ 
                        pos\) == \(-δ[[neg[[i]]]]\), 
{i, 
                    Length[neg]}]
]; 

 (*\ 
              call\ Mathematica' s\ built - 
                in\ routine\ *) 
extraPaths = \(ConstrainedMin[
ϕ, constraints, 
                  variables]\)[[2]]; 

 (*\ 
              remove\ zero\ results\ *) 
extraPaths = 
              DeleteCases[extraPaths, 
                f[_, _] -> 
                  0];
]; 

 (*\ print\ tour\ *) 
 (*\ 
            linear\ searches\ are\ used\ for\ simplicity\ *) 
Module[
{bridge, start, u, v, 
              e = edges}, 
 (*\ 
              start\ vertex\ *) 
start = 
              1; 
v = start; 
While[
              True, 
u = 
                v; 

 (*\ 
                find\ adjoined\ path, \ if\ any\ *) 
For[
                i = 1, i ≤ 
                  Length[extraPaths], \(i++\), 
If[
                  u == 
                    extraPaths[[
                        i]]·
                      from, 
j = 
                    extraPaths[[
                          i]]·count - 
                      1; 
v = 
                    extraPaths[[
                        i]]·
                      to; 
extraPaths = 
                    If[j > 0, 
ReplacePart[extraPaths, 
                        f[u, v] -> j, i], 
Delete[
                        extraPaths, 
                        i]
]; 
Break[]
]
]; 
If[
                u ≠ v, 
While[
                  u ≠ v, 
Print["Take edge ", 
                    cheapest[[u, 
                      path[[u, 
                          v]]·to]], 
" from ", u, " to ", 
                    path[[u, 
                        v]]·to]; 
\(u = 
                      path[[u, 
                          v]]·to;\)
]; 
Continue[]
]; 

 (*\ take\ existing\ edge, \ 
                using\ bridge\ last\ *) 
bridge = 
                0; 
For[i = 1, 
                i ≤ Length[e], \(i++\), 
If[
                  u == 
                    e[[i]]·from, 
If[
                    bridge == 0 || 
                      e[[i]]·to ≠ path[[u, 
                            start]]·to, 
bridge = 
                      i
]
]
]; 

 (*\ 
                finished\ when\ no\ more\ bridges\ *) 
If[
                bridge == 0, 
                Return[]]; 

v = 
                e[[bridge]]·to; 
Print["Take edge ", 
                e[[bridge]]·
                  name, 
" from ", u, " to ", 
                v]; 

 (*\ 
                remove\ the\ edge\ that' 
                  s\ been\ traversed\ *) 
e = 
                Delete[e, 
                  bridge];
]
]
];\)\)

The paper's simple example

ChinesePostman[{
{1, 2, 1, "a"}, {1, 3, 
          1, "b"}, {2, 3, 1, "c"}, 
{2, 4, 
          1, "d"}, {3, 4, 1, "e"}, {4, 1, 1, "f"}}]

Graphs with symbolic vertex labels

The code above assumes a graph is represented as a list of edges, using vertex numbers. If you use symbolic vertices, the following utility routines are handy.

ToNats converts a graph with symbolic vertices into a graph using natural numbers.

MakeVocab[s_] := 
        Union@Flatten@
            Map[Part[#, {1, 2}] &, 
              s];

\(\(WhichNat[symbol_, 
          vocab_] := \(Position[vocab, symbol]\)[[1, 
          1]];\)
\)
\(\(ToNats[s_, \ vocab_] := 
        Map[{WhichNat[#·from, vocab], 
              WhichNat[#·to, vocab], #·
                weight, #·name} &, \ s, {1}];\)
\)
ToNats[s_]  :=  ToNats[s, MakeVocab[s]]

Given a list of numbers, or a list of lists etc, and a symbolic graph, FromNats converts the numbers back to the corresponding symbols. The routine is recursively defined to handle nested lists (such as graphs themselves, which are lists of lists).

\(\(FromNats[nats_?AtomQ, s_] := \(Union[Flatten[s]]\)[[
          nats]];\)
\)
\(FromNats[nats_, \ s_] := 
	
      Map[FromNats[#, MakeVocab[s]] &, nats]\)

Here's how to use them to define a more general Chinese Postman routine:

\(CPP[s_] := 
	ChinesePostman[ToNats[s]]\)

The Nokia 2110 mobile phone

Here's a demonstration of the more general routine, operating on a mobile phone menu list. Having got a Chinese Postman routine, the tricky part is converting Nokia's definition of their phone into an edge list. The following is a Mathematica-style transcription of the menu map in the Nokia 2110 user manual; it defines a function menu.

\(\(nokiaMenu["Standby"] = {"Recent calls", "Messages", "Call divert", "Phone settings", "Security options", "Duration and cost", "Network selection", "Memory functions", "Personal reminders", "In-call options", "FAX or data call", "Ringing options", "Number editor"};\)\)
nokiaMenu["Recent calls"] = {"Dialled calls", "Received \
calls", "Missed calls", "Erase all recent calls"};
nokiaMenu["Messages"] = {"Listen to voice messages", "Read \
messages", "Write messages", "Show deliver reports", "Message \
settings"};
\(\(nokiaMenu["Message settings"] = {"Message centre number", "Message sent as", "Accept reply costs", "Delivery reports", "Message validity", "Set mailbox number"};\)\)
\(\(nokiaMenu["Call divert"] = {"Divert all calls", "Divert when busy", "Divert when not answered", "Divert if not reachable", "Divert all data calls", "Cancel all diverts"};\)\)
\(\(nokiaMenu["Phone settings"] = {"Lights", "Ringing volume", "Ringing tone", "Keypad tones", "Warning tones", "Automatic redial", "One touch dialling", "Automatic answer", "Cell info display", "Own number sending", "Call waiting", "Restore factory settings", "Menu list", "Language"};\)\)
\(\(nokiaMenu["Security options"] = {"PIN code request", "Security level", "Call barring", "View fixed dialling", "Change access codes", "Closed user group"};\)\)
\(\(nokiaMenu["Call barring"] = {"Outgoing calls", "International calls", "Int except to home country", "Incoming calls", "Incoming calls if abroad", "Cancel all barrings"};\)\)
\(\(nokiaMenu["Change access codes"] = {"Change security code", "Change PIN code", "Change PIN2 code", "Change barring password"};\)\)
nokiaMenu["Duration and cost"] = {"Call duration", "Call \
costs", "Call costs limit", "Show costs in"};
\(\(nokiaMenu["Memory functions"] = {"Memory selection", "Memory status", "Copy between memories", "Memory erasing options", "Show own number"};\)\)
\(\(nokiaMenu["Personal reminders"] = {"Welcome note", "Countdown timer"};\)\)
nokiaMenu[_]  =  {};

This has to be converted to an edge list. Since this is tricky, the function transition, which collects the edges, is also passed a parameter giving the button press for that edge, which is useful for debugging, since the transitions can easily be checked against the Nokia mobile itself.

\(\(makeGadget[fcn_, root_] := 
	
        Module[{defList = {}, counter = 0, transition, domenu}, 
          transition[from_, button_, to_]\  := 
            AppendTo[defList, {from, to, 1, "to " <> to}]; 
		domenu[
              s_] := Module[{i, m = fcn[s], view}, 
              view = "View options "\  <> \ 
                  ToString[\(++counter\)]; 
				transition[
                s, "Select", view]; 
				transition[view, "Up", 
                m[[Length[m]]]]; 
              transition[view, "Down", 
                m[[1]]]; 
				transition[view, "Quit", s\ ]; 
				For[i = 1, 
                i ≤ Length@m, \(i++\), 
					transition[
                  m[[i]], "Down", 
                  m[[If[i == Length[m], 1, 
                      i + 1]]]]; 
                transition[
                  m[[i]], "Up", 
                  m[[If[i == 1, Length[m], 
                      i - 1]]]]; 
                transition[
                  m[[i]], "Quit", 
                  s]; 
					If[\ 
                  fcn[m[[
                        i]]\ ] ≠ {}, 
                  domenu[m[[
                      i]]]]]
			]; 
		domenu[
            root]; 
	Return[defList]
	];\)\)

nokiaList = makeGadget[nokiaMenu,  "Standby"];

Write the CPP to a file, and then count how many lines were generated, excluding lines that describe "paths". This simply counts the length, in edges, of the CPP.

\(\(Module[{tmp = $Output, s}, 
$Output = 
          OpenWrite["tmp"]; 
CPP[
          nokiaList]; 
Close[$Output]; 
$Output = tmp; 
s = 
          Import["tmp", "Lines"]; 
For[
          i = Length[s], i > 0, \(i--\), 
          If[StringMatchQ[
              s[[
                i]], "*path*"], 
s = 
              Delete[s, i]]]; 
tour = 
          Length[s]
];\)\)
Print["Vertices=", 
      n = Length@Union@
            Map[#[[1]] &, 
              nokiaList], "\nEdges=", 
      Length@nokiaList, "\nLength of CPT=", tour - 1]

Timing[CPP[nokiaList]]

So the length of a test that each button press (i.e., edge) of the Nokia phone is correct will take 515 button presses. However, some buttons will occasionally not have any effect. The Nokia has 4 (Up, Down, Quit, Select) buttons, so any vertex with fewer than 4 out-edges has some inactive buttons. So the total of the product of the number of states times the number of buttons minus the sum of the out-degrees (i.e., the number of transitions in the finite state machine) gives us the extra number of presses to check the Nokia phone is understood.

\(\(outDegrees[edgeList_] := 
        Module[{d = 
              Table[0, {Max[
                    Map[\((#·edge)\) &, 
                      edgeList]]}]}, 
		Scan[\(d[[#[[1]]]]++\) &, 
            edgeList]; \ d];\)
\)
\(Module[{extra = Apply[Plus, 4 - outDegrees[ToNats@nokiaList]]}, 
	
      Print["Extra (null) presses=", extra, "
Total cost of check=", 
        extra + tour]]\)

Convert Mathematica format to Java

toJava[
        s_] := {WriteString[$Output, "{ Graph G = new Graph(", 
          Max[Map[#·from &, ToNats[s]]], ");\n"]; 
        Scan[WriteString[$Output, "  G.addEdge(\"", #·
                name, "\",", #·from - 
                1, ",", #·to - 1, ",", #·
                weight, ");\n"] &, ToNats[s]]; 
        WriteString[$Output, "  G.cpt(0);\n}\n"]}

toJava[nokiaList];