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[]:=
GraphRules0[ls_]:=Join[Union[Select[#,SameQ@@#&]],Select[Flatten[MapIndexed[#2[[1]]Quotient[#+2,3]&,ls/.{h[n_]3(n+Length[ls])},{2}]],#[[1]]<#[[2]]&]]&[Flatten[MapIndexed[#2[[1]]Quotient[#+2,3]&,ls/.{h[n_]3(n+Length[ls])},{2}]]]
In[]:=
IconObject[{base1_,base2_},pts0_,r_]:=With[{base={base1,base2}},With[{pts=If[UnsameQ@@Quotient[2+#[[2]]&/@pts0,3],First/@pts0,With[{pos=Quotient[2+#[[2]]&/@pts0,3]/.{{x_,x_,x_}{1,2,3},{x_,x_,_}{1,2,0},{x_,_,x_}{1,0,2},{_,x_,x_}{0,1,2}}},If[(Cases[Last/@pts0,_Integer,1,1][[1]])(Select[Split[Sort[Cases[Quotient[2+#[[2]]&/@pts0,3],_Integer,1]]],Length[#]>1&][[1,1]]),With[{pt=pts0[[Position[pos,0][[1,1]],1]]},Map[repositionmultiples[base,pt,#.1]&,pos/.{2-1}]],With[{cors=If[Cases[Last/@pts0,_Integer,1,1][[1]]>Select[Split[Sort[Cases[Quotient[2+#[[2]]&/@pts0,3],_Integer,1]]],Length[#]>1&][[1,1]],pos,pos/.MapIndexed[##2[[1]]&,Reverse[Ordering[Mod[2+#[[2]]&/@pts0,3][[Flatten[Position[pos,1|2|3]]]]]]]]},MapIndexed[If[MatchQ[cors[[#2[[1]]]],0|2],#,repositionmultiples[base,#,Sign[cors[[#2[[1]]]]-2].1]]&,First/@pts0]]]]]},With[{uvecs=iconpoints3[Function[p,If[pbase,{1,0},(p-base)/Norm[p-base]]]/@pts]},With[{mids=MapThread[Plus,{uvecs,RotateLeft[uvecs]},1]/2},Table[{{Red,Green,Blue}[[i]],Polygon[{base,Offset[rmids[[i]],base],Offset[ruvecs[[i]],base],Offset[rmids[[Mod[i-1,3,1]]],base]}]},{i,3}]]]]]
In[]:=
repositionmultiples[p1_,p2_,d_]:=p2+d#/Norm[#]&[(p1-p2).{{0,1},{-1,0}}]
In[]:=
iconpoints3[{a_,b_,c_}]:=If[ab,{c.{{Cos[2Pi/3],Sin[2Pi/3]},{-Sin[2Pi/3],Cos[2Pi/3]}},c.{{Cos[2Pi/3],-Sin[2Pi/3]},{Sin[2Pi/3],Cos[2Pi/3]}},c},If[ac,{b.{{Cos[2Pi/3],Sin[2Pi/3]},{-Sin[2Pi/3],Cos[2Pi/3]}},b,b.{{Cos[2Pi/3],-Sin[2Pi/3]},{Sin[2Pi/3],Cos[2Pi/3]}}},If[bc,{a,a.{{Cos[2Pi/3],Sin[2Pi/3]},{-Sin[2Pi/3],Cos[2Pi/3]}},a.{{Cos[2Pi/3],-Sin[2Pi/3]},{Sin[2Pi/3],Cos[2Pi/3]}}},Nest[Map[#/Norm[#]&,#-RotateRight[#]&[Map[Max[0,(1.6-.8#)/#]&[Norm[#]]#&,{#[[1]]-#[[2]],#[[2]]-#[[3]],#[[3]]-#[[1]]}]]+#]&,{a,b,c},2]]]]
In[]:=
ColoredGraphPlot[ls_,opts___]:=Module[{graph,coordinates},graph=Graph[Sort[VertexList[Graph[GraphRules0[ls]]]],GraphRules0[ls]];coordinates=GraphEmbedding[graph,"SpringElectricalEmbedding"];Graph[graph,opts,VertexSizeSmall,VertexShapeFunctionFunction[{center,name,size},If[name≤Length[ls],IconObject[center,If[IntegerQ[#],{coordinates[[Quotient[2+#,3]]],#,name},{coordinates[[Length[ls]+First[#]]],#}]&/@ls〚name〛,0.2*^3Max[size]],Circle[center,Max[size]]]],PerformanceGoal"Quality",VertexCoordinatesThread[Range[VertexCount[graph]]coordinates],DirectedEdgesFalse,EdgeStyleDirective[Gray,Thick],VertexStyleDirective[Gray,Thick]]]
In[]:=
$arrow=FilledCurve[{{{0,2,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0}}},{{{-1.,0.1848},{0.2991,0.1848},{-0.1531,0.6363},{0.109,0.8982},{1.,0.0034},{0.109,-0.8982},{-0.1531,-0.6363},{0.2991,-0.1848},{-1.,-0.1848},{-1.,0.1848}}}];
In[]:=
ColoredRulePlot[in_out_,padding_List:Automatic,opts:{{OptionsPattern[]},{OptionsPattern[]}}:{{},{}}]:=Module[{outCoordinates,inPlot,outPlot,plotRange,explicitPadding,finalPlots},outCoordinates=Take[GraphEmbedding[Echo@ColoredGraphPlot[out],"SpringElectricalEmbedding"],Length[Cases[in,_h,{2}]]];inPlot=ColoredGraphPlot[in,Sequence@@opts〚1〛,GraphLayout"SpringElectricalEmbedding",VertexCoordinatesThread[Range[Length[in]+Length[outCoordinates]]ConstantArray[Automatic,Length[in]]~Join~outCoordinates]];outPlot=ColoredGraphPlot[out,Sequence@@opts〚2〛,GraphLayout"SpringElectricalEmbedding",VertexCoordinatesThread[Range[Length[out]+Length[outCoordinates]]ConstantArray[Automatic,Length[out]]~Join~outCoordinates]];explicitPadding=Replace[padding,Automatic{{0.2,0.2},{0.2,0.2}}];plotRange={{#〚1,1〛-explicitPadding〚1,1〛(#〚1,2〛-#〚1,1〛),#〚1,2〛+explicitPadding〚1,2〛(#〚1,2〛-#〚1,1〛)},{#〚2,1〛-explicitPadding〚2,1〛(#〚2,2〛-#〚2,1〛),#〚2,2〛+explicitPadding〚2,2〛(#〚2,2〛-#〚2,1〛)}}&@(MinMax/@Transpose[Catenate[AbsoluteOptions[#,VertexCoordinates]〚1,2〛&/@{inPlot,outPlot}]]);finalPlots=(Framed[Graph[#,PlotRangeplotRange,ImageSize128],FrameStyleGrayLevel[0.7]]&/@{inPlot,outPlot});Row[{finalPlots〚1〛,Graphics[{GrayLevel[0.65],$arrow},ImageSize0.22128],finalPlots〚2〛}]]
In[]:=
ColoredGraphPlot[{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}},VertexLabelsAutomatic]
Out[]=
In[]:=
ColoredRulePlot[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}]
»
Out[]=
In[]:=
Take[Range[10],-4]
Out[]=
{7,8,9,10}
In[]:=
ColoredRulePlot[{{2,1,4},{3,h[1],h[2]}}{{h[1],5,4},{3,2,h[2]}}]
Out[]=
In[]:=
RulePlot[WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}]]]
Out[]=
In[]:=
ColoredRulePlot[{{2,1,4},{3,h[1],h[2]}}{{h[1],5,4},{3,2,h[2]}},{{0.1,0.1},{0.7,0.3}},{{VertexSize0.4},{VertexSize0.3}}]
Out[]=
In[]:=
ColoredGraphPlot[{{2,1,4},{3,h[1],h[2]}}]ColoredGraphPlot[{{h[1],5,4},{3,2,h[2]}}]
Out[]=
In[]:=
ColoredGraphPlot[{{2,1,4},{3,h[1],h[2]}}]
Out[]=
In[]:=
ColoredGraphPlot[{{h[1],h[2],h[3]}}]
Out[]=