wolf-goat-cabbage graph
- To: mathgroup at smc.vnet.net
- Subject: [mg80008] wolf-goat-cabbage graph
- From: Yaroslav Bulatov <yaroslavvb at gmail.com>
- Date: Fri, 10 Aug 2007 06:38:24 -0400 (EDT)
Does anyone see a concise Mathematica way to visualize the search task
in the wolf-goat-cabbage puzzle?
One version is below, where you have to go from Green to Blue without
following any Red-Red transitions, but it feels verbose.
states = Tuples[{0, 1, 2}, 3];
states = Select[states, Length[Cases[#, 1]] < 2 &];
pairs = Tuples[states, 2];
arrows = Rule @@@
Pick[pairs, Total[Abs[#[[1]] - #[[2]]]] & /@ pairs, 1];
states = Union[Flatten[arrows, 2, Rule]];
forbidden =
Select[states, (#[[1]] == #[[2]]) ~Or~(#[[2]] == #[[3]]) &];
vertfun := Which[
#2 == {0, 0, 0},
{Opacity[.6], EdgeForm[Black], Green, Disk[#1, {0.3, .2}], Black,
Opacity[1], Text[#2, #1]},
#2 == {2, 2, 2},
{Opacity[.6], EdgeForm[Black], Blue, Disk[#1, {0.3, .2}], Black,
Opacity[1], Text[#2, #1]},
forbidden~MemberQ~#2,
{Opacity[.6], EdgeForm[Black], Red, Disk[#1, {0.3, .2}], Black,
Opacity[1], Text[#2, #1]},
True,
{Opacity[.6], EdgeForm[Black], Yellow, Disk[#1, {0.3, .2}], Black,
Opacity[1], Text[#2, #1]}
] &;
GraphPlot[arrows, VertexLabeling -> True,
VertexRenderingFunction -> vertfun, DirectedEdges -> True]