Thanks for the appreciation!
Update: I decided to write a quick branch-and-bound algorithm (code below), and verified the minimal results found above. My time for solving the minimal switches and treasure path was about 30 minutes. If anyone can improve significantly on that time, please speak up and say how!
more calculation
more calculation
Import the relevant data:
Import the relevant data:
In[]:=
edges=;
In[]:=
switches=;
In[]:=
treasure=;
In[]:=
gtest=Graph[edges]
Out[]=
Re-create the previous rigorous result:
Re-create the previous rigorous result:
In[]:=
res1=FindShortestStationRoute[gtest,"Start","End",switches];
In[]:=
Length/@res1
Out[]=
{21}
In[]:=
HighlightGraph[VertexDelete[gtest,"Out"],Graph[MapApply[DirectedEdge,Partition[res1[[1]],2,1]]]]
Out[]=
Make the previous loose result more rigorous:
Make the previous loose result more rigorous:
In[]:=
AbsoluteTiming[res2=FindShortestStationRoute[gtest,"Start","End",Join[switches,treasure]];]
{1693.137037`,Null}
In[]:=
res2=;
In[]:=
Length/@res2
Out[]=
{48,48,48,48}
In[]:=
HighlightGraph[VertexDelete[gtest,"Out"],Graph[MapApply[DirectedEdge,Partition[res2[[1]],2,1]]]]
Out[]=
code
code
In[]:=
FindShortestStationRoute[graph_,start_,end_,stations_]:=Module[{path,relevant,next,res,len,dist,minlen,stack,level},minlen=Infinity;res=Association[minlen->{}];level=0;stack=Association[-1->{"Halt"},0->{{start}}];Monitor[While[level>=0,If[SameQ[stack[level],{}],KeyDropFrom[stack,level--];stack[level]=Rest[stack[level]];Continue[];];path=First[stack[level]];relevant=Catenate[Select[stations,Not[IntersectingQ[#,path]]&]];next=Map[Join[Most[path],FindShortestPath[graph,Last[path],#]]&,relevant];If[SameQ[next,{}],len=Length[path];Which[SameQ[Infinity,dist=GraphDistance[graph,Last[path],end]],$Failed,len=len+dist;len<minlen,KeyDropFrom[res,minlen];minlen=len;res[minlen]={path},len==minlen,res[minlen]=Union[res[minlen],{path}],len>minlen,$Failed];];next=Select[next,Length[#]<=minlen&];If[SameQ[next,{}],stack[level]=Rest[stack[level]];,stack[++level]=SortBy[next,Length];]],Length/@stack];Join[Most[#],FindShortestPath[graph,Last[#],end]]&/@res[minlen]]