You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
In[]:=
graph=WolframModel[{{x,y},{z,y}}{{x,z},{y,z},{w,z}},{{0,0},{0,0}},12]["LayeredCausalGraph",VertexLabelsAutomatic,AxesTrue]
Out[]=
In[]:=
Association[Thread[VertexList[graph](VertexCoordinates/.AbsoluteOptions[graph,VertexCoordinates]〚1〛)]]
Out[]=
In[]:=
coords=VertexCoordinates/.AbsoluteOptions[graph,VertexCoordinates]〚1〛;
In[]:=
chosen=coords〚{1,2,3,5,7,10,15,21,29,76,8,41,56,11,16,23,31,44,60,82}〛;
In[]:=
chosen=coords〚1;;-2〛;
In[]:=
func1=Nearest[chosen]
Out[]=
In[]:=
func2=Nearest[Complement[coords,chosen]]
Out[]=
In[]:=
drawFoliation[graph_,vertexLists_]:=Quiet[Module[{vertexCoordinates=Association[Thread[VertexList[graph](VertexCoordinates/.AbsoluteOptions[graph,VertexCoordinates]〚1〛)]],lines},Show[graph,FoldPairList[foliationLine[vertexCoordinates],{},vertexLists]]],NearestFunction::neard]
In[]:=
foliationLine[coordinates_,style_:{Red,Dotted,Thick}][extraPoints_,chosenVertices_]:=Module[{chosenCoordinates=Join[coordinates/@chosenVertices,extraPoints],nearest1,nearest2,coordinateBounds=CoordinateBounds[coordinates]},{nearest1,nearest2}=Nearest/@{chosenCoordinates,Complement[Values[coordinates],chosenCoordinates]};{ContourPlot[EuclideanDistance[nearest1[{x,y}]〚1〛,{x,y}]-EuclideanDistance[nearest2[{x,y}]〚1〛,{x,y}]0,{x,coordinateBounds〚1,1〛,coordinateBounds〚1,2〛},{y,coordinateBounds〚2,1〛,coordinateBounds〚2,2〛},ContourStylestyle],Table[With[{x=x},Module[{func},func[y_?NumericQ]:=EuclideanDistance[nearest1[{x,y}]〚1〛,{x,y}]-EuclideanDistance[nearest2[{x,y}]〚1〛,{x,y}];{x,y/.FindRoot[func[y]0,{y,coordinateBounds〚2,1〛,coordinateBounds〚2,2〛}]}]],{x,coordinateBounds〚1,1〛,coordinateBounds〚1,2〛,1}];{}}]
In[]:=
drawFoliation[graph,(Range/@{1,2,4,6,9,13,19,26,36,51,69})〚1;;-1;;2〛]
Out[]=