Skip to main content
added 14 characters in body
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456

I got a working solution, but too heavy to be used for the full problem. I was not able to find a way for efficiently identifying isomorphic states and so my solution is a recursive hog.

I got a working solution, but too heavy to be used for the full problem. I was not able to find a way for identifying isomorphic states and so my solution is a recursive hog.

I got a working solution, but too heavy to be used for the full problem. I was not able to find a way for efficiently identifying isomorphic states and so my solution is a recursive hog.

Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456

Reader Beware: This does not solve the problem

I started trying to use graphs instead of lists with the idea of using isomorphisms to discard solution branches already explored.

I got a working solution, but too heavy to be used for the full problem. I was not able to find a way for identifying isomorphic states and so my solution is a recursive hog.

Anyway, as I am not going to spend more time with it for a while, I decided to post the code here, for the benefit of others trying the graph way.

Here it is:

(* manufacture vertex positions :) *)
places = MaxFilter[CrossMatrix[3], 1];
placesPos = Position[places, 1];
mPos = Max@placesPos;
pegNum = Length@placesPos;
g = Graph[Array[# &, pegNum], {}, VertexCoordinates -> placesPos, VertexLabels -> "Name", ImagePadding -> 10];

(*Allowable jumps *)

j1 = Select[Flatten[Table[Intersection[{{k, i}, {k, i + 1}, {k, i + 2}}, placesPos], 
           {k, mPos}, {i, mPos}], 1], Length@# == 3 &];
j2 = Select[Flatten[Table[Intersection[{{k, i}, {k + 1, i}, {k + 2, i}}, placesPos], 
           {k, mPos}, {i, mPos}], 1], Length@# == 3 &];
th = Thread[IntegerPart /@ PropertyValue[{g, #}, VertexCoordinates] & /@ VertexList[g] -> VertexList[g]];
j = Union[j1, j2] /. th;
jumps = UndirectedEdge @@@ (j[[All, {1, 3}]]);

(*test drive graph*)
g1 = Graph[Table[i, {i, pegNum}], jumps, VertexCoordinates -> placesPos, 
         VertexLabels -> "Name", ImagePadding -> 10];
(*jump over what vertex for each transition *)
(PropertyValue[{g1, #[[1]]}, "jOver"] = #[[2]]) & /@ Transpose[{jumps, j[[All, 2]]}];
(*Initially Occupied Vertex stock  Replace "7" with pegNum for a looong wait*)
(PropertyValue[{g1, #[[1]]}, "occ"] = #[[2]]) & /@ Table[{i, If[i <= 7, True, False]}, {i, pegNum}];

(*Utility funcs*)
SetAttributes[{freeV, jOver, pMoves, seeBoard, doMove, ret},  HoldFirst];
freeV[g_, x_] := ! PropertyValue[{g, x}, "occ"]; (*is the vertex free?*)
jOver[x_UndirectedEdge] := PropertyValue[{g1, x}, "jOver"]; (*Which vertex to jump over?*)
(*Select Possible moves at a certain graph state*)
pMoves[g_] := Select[jumps, ((freeV[g, #[[1]]]) != freeV[g, #[[2]]]) && (! freeV[g, jOver[#]]) &];
(*Utility for drawing  occupancy*)
seeBoard[g_] := Module[{}, 
    vf[{xc_, yc_}, name_, {w_, h_}] :=If[freeV[g, name], {Blue, #}, {Red, #}] &@ Disk[{xc, yc}, Min@{w, h}];
       Graph[Table[i, {i, pegNum}], jumps, VertexCoordinates -> placesPos,
            VertexLabels -> "Name", ImagePadding -> 10, VertexShapeFunction -> vf, Frame -> True]];
(*perform a move> blank jOver vertex and traslate original*)
(*Note that we can't distinguish source & destination*)
(* Does not check if initial conditions are met*)
doMove[g_, x_UndirectedEdge] :=
  (PropertyValue[{g, x[[1]]}, "occ"] = !PropertyValue[{g, x[[1]]}, "occ"];
   PropertyValue[{g, x[[2]]}, "occ"] = !PropertyValue[{g, x[[2]]}, "occ"];
   PropertyValue[{g, jOver[x]}, "occ"] = False;);
(*Test move*)
(*seeBoard[g1]
doMove[g1,1\[UndirectedEdge]9];*)
seeBoard[g1]
(*solving function*)
ret[g_, m_] := Module[{c := g}, 
              If[(pMoves[g] != {}), 
                Module[{k = c}, (doMove[k, #]; ret[k, Append[m, #]])] & /@  pMoves[g]]; Sow[m]];
(*Check results. We dont distinguish between a->b and b->a yet!*)
l = (Reap@ret[g1, {}])[[2, 1]];
Length@l
TableForm@Select[l, (Length@# == (Max@(Length /@ l))) &]