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
HypergraphPlot with self-loops
HypergraphPlot with self-loops
New code
New code
We still assume each relation is a polygon, however, we now simulate this polygon with a triangulated region, which we embed with SpringElectricalEmbedding after identifying some corner vertices.
We thus get effects similar to “bending paper”.
In[]:=
?TriangulateMesh
Out[]=
In[]:=
triangulatedPolygon[n_,opts___]:=TriangulateMesh[RegularPolygon[n],opts]
In[]:=
triangulatedPolygon/@{3,4,8}
Out[]=
In[]:=
ClearAll[flatPolygonGraph];flatPolygonGraph[ns_List,opts___]:=With[{separateGraphs=If[#>2,Graph[UndirectedEdge@@@Flatten[List@@@MeshCells[triangulatedPolygon[#,opts],1],1]],If[#2,Graph[{13,34,45,56,67,78,89,910,102},DirectedEdgesFalse],Graph[{1},{}]]]&/@ns},Reap[FoldList[With[{indexGraph=Sow[VertexReplace[#2,n_n+#1-1]]},Max@VertexList[indexGraph]+1]&,1,separateGraphs]]〚2,1〛]
In[]:=
RepeatedTiming[flatPolygonGraph$old[4]]
Out[]=
In[]:=
RepeatedTiming[flatPolygonGraph$new[4]]
Out[]=
In[]:=
flatPolygonGraph/@{3,4,8}
Out[]=
The faces can be extracted which we will use for visualizing the polygon:
In[]:=
ClearAll[polygonFaces];polygonFaces[n_,opts___]/;n>2:=Flatten[List@@@MeshCells[triangulatedPolygon[n,opts],2],1]polygonFaces[1|2,opts___]:={}
In[]:=
HypergraphPlotSW[polygonFaces[3]]
Out[]=
In[]:=
?MeshConnectivityGraph
Out[]=
In[]:=
Graph[MeshConnectivityGraph[TriangulateMesh[RegularPolygon[3]],0],GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic]
Out[]=
In[]:=
origamiCoordinates[shapes:{{__Integer}..},opts___]:=With[{graphs=flatPolygonGraph[Length/@shapes,opts]},With[{identifications=Catenate@MapIndexed[Sort[VertexList[graphs[[#2[[1]]]]]][[#2[[2]]]]With[{firstPosition=FirstPosition[shapes,#]},Sort[VertexList[graphs〚firstPosition〚1〛〛]]〚firstPosition〚2〛〛]&,shapes,{2}]},Join[#,identifications/.(a_b_)(a(b/.#))]&@Thread[VertexList[#]GraphEmbedding[#]&@VertexReplace[If[Length[{##}]>1,GraphUnion[##],GraphUnion[#,#]]&@@graphs,identifications]]]]
In[]:=
ClearAll[polygonGraphics];polygonGraphics[shapes:{{__Integer}..},opts___]:=With[{graphs=flatPolygonGraph[Length/@shapes,opts]},Graphics[Style[Polygon[#],Opacity[.3],Hue[0.6,0.7,0.5]]&/@(Catenate[#〚1〛+Min[VertexList[#〚2〛]]-1&/@Transpose[{polygonFaces[Length[#],opts]&/@shapes,graphs}]]/.origamiCoordinates[shapes,opts])]]
In[]:=
ClearAll[edgeGraphics];edgeGraphics[shapes:{{__Integer}..},opts___]:=With[{graphs=flatPolygonGraph[Length/@shapes,opts]},With[{coordinateRules=origamiCoordinates[shapes,opts],vertexSequences=Function[{graph,shape},FindShortestPath[EdgeList[graph]//Graph,##]&@@@Partition[Range[Length[shape]]+Min[VertexList[graph]]-1,2,1]]@@@Transpose[{graphs,shapes}]},Graphics[Style[Arrow[#],Hue[0.6,0.7,0.5],Opacity[0.7]]&/@(vertexSequences/.coordinateRules)]]]
In[]:=
vertexGraphics[shapes:{{__Integer}..},opts___]:=With[{coordinateRules=origamiCoordinates[shapes,opts]},Graphics[Style[Disk[#/.coordinateRules,0.2],Hue[0.6`,0.2`,0.8`],EdgeForm[{GrayLevel[0],Opacity[0.7`]}]]&/@Catenate[(Range[Length[#2]]+Min[VertexList[#1]]-1&)@@@Transpose[{flatPolygonGraph[Length/@shapes],shapes}]]]]
In[]:=
relationGraphics[shapes:{{__Integer}..},opts___]:=Show[polygonGraphics[shapes,opts],edgeGraphics[shapes,opts],vertexGraphics[shapes,opts]]
Examples
Examples
In[]:=
relationGraphics[{{1,2,3}}]
Out[]=