MathGroup Archive 2007

[Date Index] [Thread Index] [Author Index]

Search the Archive

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]



  • Prev by Date: Re: Simplifying the exponents
  • Next by Date: 64 bit Kernel does not run on iMac Intel
  • Previous by thread: what am i doing wrong
  • Next by thread: 64 bit Kernel does not run on iMac Intel