Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

A drunken man walks in a two-dimensional grid.He can walk rigth(1),down(2),left(3),up(4).After determined number of steps,for example,6 steps,he has 400 ways go back home(the number of 1(2) equal to 3(4),assume the number of 2(3) larger tan 1(3),then just 200 ways).

move = {1, 2, 3, 4};
AllWays[n_ /; EvenQ[n]] := {{1, 3} & /@ Range[#1], {2, 4} & /@ Range[#2]} & @@@
   PadLeft[IntegerPartitions[n/2, {0, 2}]] // Flatten /@ # & // Permutations /@ # & 
   // Join @@ # &

so if 6 steps,we will get:

{{2, 4, 2, 4, 2, 4}, {2, 4, 2, 4, 4, 2}, << 196 >>, {4, 2, 3, 1, 3, 1}, {4, 2, 3, 3, 1, 1}}

we can plot arrow pictures for this.

rule = {1 -> {1, 0}, 2 -> {0, -1}, 3 -> {-1, 0}, 4 -> {0, 1}};
handle[list_] := With[{n = Length[list] - 1},
    If[First[Subtract @@ #] == 0, 
      # + If[#[[1, 2]] < #[[2, 2]],{{0, 0.1}, {0, -0.1}}, {{0, -0.1}, {0,0.1}}], 
      # + If[#[[1, 1]] < #[[2, 1]], {{0.1, 0}, {-0.1, 0}}, {{-0.1, 0}, {0.1, 0}}]]
    & /@ (Transpose[{list,If[First[#2 - #1 & @@ First[list]] == 0,
     {{#, 0}, {#, 0}},{{0, #}, {0, #}}] & /@ Range[-0.05 n, 0.05 n, 0.1]}] 
     // Plus @@@ # &)]
ArrowPlot[moves_] := 
    Gather[Partition[Accumulate[moves /. rule], 2, 1, 1],Sort[#1] == Sort[#2] &] 
    //handle /@ # & // Flatten[#, 1] & 
    //Graphics[{Arrowheads[Medium], Arrow[#]}, ImageSize -> {70, 70}] &

so ArrowPlot[{1, 1, 4, 2, 3, 2, 3, 4}] will get:

enter image description here

But there are three types of equivalence.

1.Topologically equivalence For example,{1, 2, 3, 4, 3, 4, 2, 1} is equal to {1, 2, 3, 4, 3, 2, 4, 1},because the images is

enter image description here

2.Translational equivalence For example,{1, 4, 1, 3, 3, 2} is equal to {4, 1, 3, 3, 2, 1},because they just have diffencnce origin,the images is

enter image description here

3.Rotate or reflect equivalence For example,{1, 4, 1, 3, 3, 2} is equal to {1, 2, 3, 2, 4, 4},because the images is

enter image description here

Obviously in 6 steps,Length[AllWays[6]] just equal to 200.It just has 7 difference ways,the images is

enter image description here

but in 8(10) steps,Length[AllWays[8(10)]] equal to 3710(31752).and the difference ways just equal to 20+(100+),how to write a program to tally those?

share|improve this question
add comment

3 Answers

Here's a start -- note my first complete tuple list is larger that yours, i didn't sort out where the differece is.

n = 8;
(all = Select[ Tuples[ Range[4] , n], 
   Length[Cases[#, 2]] == Length[Cases[#, 4]] && 
      Length[Cases[#, 1]] == Length[Cases[#, 3]] & ]) // Length
cycmatch[a_, b_, n_] := ( 
      Position[  
            NestList[ Function[{list}, Permute[ list, Cycles[{Range[n]}]]] , 
                           a  , n ] , (b ) ] != {} );
(all = DeleteDuplicates[ all , cycmatch[#2, #1, n] &  ]) // Length    
(all = DeleteDuplicates[ all , 
         cycmatch[#2, #1 /. { 1 -> 3 , 3 -> 1}, n] &  ] ) // Length
(all = DeleteDuplicates[ all , 
         cycmatch[#2, #1 /. { 2 -> 4 , 4 -> 2}, n] &  ] ) // Length
(all = DeleteDuplicates[ all , 
         cycmatch[#2, #1 /. { 1 -> 2 , 2 -> 3, 3 -> 4 , 4 -> 1 } , n] &  ] ) // Length
(all = DeleteDuplicates[ all , 
         cycmatch[#2, #1 /. { 2 -> 1 , 1 -> 4, 4 -> 3 , 3 -> 2 }, n] &  ] ) // Length
(all = DeleteDuplicates[ all , 
         cycmatch[#2, #1 /. { 1 -> 3 , 2 -> 4, 3 -> 1 , 4 -> 2 },  n] &  ] ) // Length

4900 618 319 254 201 175 124

So we have 124 unique paths using only symmetry based matching:

 ArrowPlot[list_] := 
    Graphics[{Arrowheads[.3], 
      Arrow /@ Rest@FoldList[ { Last@#1 , Last@#1  +  Piecewise[
         {{ {1, 0} , #2 == 1} ,  {{0, -1} , #2 == 2} , 
         {{ -1, 0} , #2 == 3} , {{0, 1} , #2 == 4}  }  ]
            } & , {{0, 0}, {0, 0}}, list ]} ]

 GraphicsGrid[Map[ArrowPlot , Partition[all, 11] , {2}]]

enter image description here

Edit, considering 'reversed' paths to be eqivalent we are left with 93. Shown here sorted by the number of unique path elements:

enter image description here

Going further you need to clarify (mathematically) what you mean by topological equivalence.

share|improve this answer
add comment

As it does not really matter the order in which the steps are performed, all you need to do is to sort the vector prior to tally. (It is the same {Left, Left, Up, Left) than {Up, Left, Left, Left}). Thus

Tally[Sort[#] & /@ AllWays[6]
share|improve this answer
add comment

For topologically equivalence,we can write a function.

toPoints[moves_] := With[{point = RotateRight@Accumulate[moves]}, 
  point /. Rule @@@ (Transpose[{#, Range[Length@#]}] &@DeleteDuplicates[point])]
Tally[AllWays[8], toPoints[#1 /. rule] == toPoints[#2 /. rule] &];

point is the trajectory.For example,{1,1,1,3,3,3}

In[33]= RotateRight@Accumulate[{1,1,1,3,3,3}/.rule]
Out[33]={{0,0}(*strat from origin*),{1,0}(*move right*),{2,0},{3,0},
       {2,0}(*move left*),{1,0}}

toPoints give the points move.so if two ways has the same trajectory,then they are topologically equivalence.

In[44]:= toPoints[{1,1,1,3,3,3}/.rule]
         toPoints[{1,1,2,4,3,3}/.rule]
Out[44]= {1,2,3,4,3,2}
Out[45]= {1,2,3,4,3,2}

so this two images are same to each ohter.

enter image description here

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.