![enter image description here](http://community.wolfram.com//c/portal/getImageAttachment?filename=dsfare4q5ywhtrgeaf.gif&userId=11733)
This is a code I developed last year, while trying to solve an Atari game. The main idea is to go from the initial part of the lattice (A first row) to the last row (B) deviating from obstacles (in this case, cars, black squares). The goal of the model is to find the shortest path between A and B, given the cars in the road. Initially I thought I could use tuples of paths in the 6 x 15 lattice, but the possible options were computationally expensive.
a=Table[Insert[Table[0,{5}],1,RandomInteger[{1,5}]],{15}];
{ArrayPlot[a,Mesh->True,ImageSize->180,Frame->True]}
Green square is car moving:
![Lattice](http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-01-10at8.38.03PM.png&userId=992056)
So I used a Markov Chain Monte Carlo model, using Markov Chains to generate possible paths given spatial restrictions.
b=Partition[Flatten[Position[a[[#]],0]&/@Table[k,{k,1,Dimensions[a][[1]],1}]],5]
h=b[[#]][[RandomInteger[{1,5}]]]&/@Table[k,{k,1,Dimensions[a][[1]],1}]
g1=Flatten[{h[[#]]->h[[#+1]]}&/@Table[k,{k,1,14,1}]]
hh=Insert[a[[#]],2,h[[#]]]&/@Table[k,{k,1,Dimensions[a][[1]],1}]
f1=Delete[hh[[#]],h[[#]]+1]&/@Table[k,{k,1,Dimensions[a][[1]],1}]
{LayeredGraphPlot[g1,VertexLabeling->True,ImageSize->360],Dynamic[j=Clock[{1,15,1},5];{ArrayPlot[bb=Insert[Delete[a,j],f1[[j]],j],Mesh->True,ImageSize->170,ColorRules->{0->White,1->Black,2->Green}],Grid[Insert[Delete[a,j],f1[[j]],j]/.{0->'blank',1->'black car',2->'orange car'}]}]}
![Car Code](http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-01-10at8.44.12PM.png&userId=992056)
Generating this dynamic output:
![Markov Chains-Lattice-Path](http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-01-10at8.41.25PM.png&userId=992056)
Then the possible paths are shown:
r={b[[1]][[1]],b[[2]][[#]],b[[3]][[#]],b[[4]][[#]],b[[5]][[#]],b[[6]][[#]],b[[7]][[#]],b[[8]][[#]],b[[9]][[#]],b[[10]][[#]],b[[11]][[#]],b[[12]][[#]],b[[13]][[#]],b[[14]][[#]],b[[15]][[#]]}&/@Table[k,{k,1,5,1}]
g12={r[[#]][[1]]->r[[#]][[2]],r[[#]][[2]]->r[[#]][[3]],r[[#]][[3]]->r[[#]][[4]],r[[#]][[4]]->r[[#]][[5]],r[[#]][[5]]->r[[#]][[6]],r[[#]][[6]]->r[[#]][[7]],r[[#]][[7]]->r[[#]][[8]],r[[#]][[8]]->r[[#]][[9]],r[[#]][[9]]->r[[#]][[10]],r[[#]][[10]]->r[[#]][[11]],r[[#]][[11]]->r[[#]][[12]],r[[#]][[12]]->r[[#]][[13]],r[[#]][[13]]->r[[#]][[14]],r[[#]][[14]]->r[[#]][[15]]}&/@Table[k,{k,1,5,1}]
q=LayeredGraphPlot[g12[[#]],VertexLabeling->True,ImageSize->180]&/@Table[k,{k,1,5,1}]
![Markov Chains](http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-01-10at8.47.37PM.png&userId=992056)
And a Manipulate command is inserted to show car movements in each path:
ft[t_]:=Insert[a[[#]],2,r[[t]][[#]]]&/@Table[k,{k,1,Dimensions[a][[1]],1}]
hh2=ft/@Table[k,{k,1,Dimensions[r][[1]],1}]
gh[ty_]:=Delete[hh2[[ty]][[#]],r[[ty]][[#]]+1]&/@Table[k,{k,1,Dimensions[a][[1]],1}]
f13=gh/@Table[k,{k,1,Dimensions[hh2][[1]],1}]
Manipulate[Dynamic[j=Clock[{1,15,1},5];{ArrayPlot[Insert[Delete[a,j],f13[[ss]][[j]],j],Mesh->True,ImageSize->230,ColorRules->{0->White,1->Black,2->Green}],Grid[Insert[Delete[a,j],f13[[ss]][[j]],j]/.{0->,1->,2->}]}],{ss,1,5,1,Appearance->"Open"}]
Then the shortest path is chosen:
dg=Total[Abs[{r[[#]][[1]]-r[[#]][[2]],r[[#]][[2]]-r[[#]][[3]],r[[#]][[3]]-r[[#]][[4]],r[[#]][[4]]-r[[#]][[5]]}]]&/@Table[k,{k,1,Dimensions[r][[1]],1}]
Insert[Delete[a,#],f13[[1]][[#]],#]&/@Table[k,{k,1,5,1}]
{q[[Flatten[Position[dg,Min[dg]]][[1]]]],ArrayPlot[hh2[[1]],Mesh->True,ImageSize->220,ColorRules->{0->White,1->Black,2->Green}]}
![Shortest path](http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-01-10at8.52.40PM.png&userId=992056)
For a video of the output, please access my YouTube video on MCMC: Markov Chain Monte Carlo
![enter image description here](http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-01-11at12.31.08PM.png&userId=11733)
Attachments: