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
Colored Networks Shapes
Colored Networks Shapes
Max Piskunov : 18d5b5be502016a808b7fc60889568d42ce95b95
Source Code
Source Code
User Policies
User Policies
In[]:=
excludeUser[username_]:=Function[expr,If[$UserName=!=username,expr],HoldAll]
In[]:=
excludeStephen=excludeUser["sw"];
Dependencies
Dependencies
In[]:=
excludeStephen[<<SetReplace`;Quiet[ParallelEvaluate[<<SetReplace`],CloudConnect::clver]];
In[]:=
getResourceFunction[filename_]:=excludeStephen@NotebookEvaluate[FileNameJoin[filename],EvaluationElements"InitializationCell"]
In[]:=
getResourceFunction[FileNameJoin[{$Dropbox,"Physics/CodeDevelopment/FunctionRepositorySources",#<>".nb"}]]&/@{"ParallelMapMonitored","OrderedGraphModelPlot","FindCanonicalWolframModel"};
In[]:=
getResourceFunction[FileNameJoin[{$Dropbox,"Physics/WorkingMaterial/2020",#<>".nb"}]]&/@{"UnorderedHypergraphs-01"};
Data
Data
In[]:=
{$rewritesOrdered24h4,$rewritesOrdered24h4RNSO,$rewritesOrdered24h4Reversible,$rewritesOrdered24h4LinR}=Import[FileNameJoin[{$Dropbox,"Physics/SW2004Material/Data/RewritesOrdered24h4.m"}],"ExpressionList"];
Model Translation
Model Translation
In[]:=
coloredSpecPattern={{___}...};
In[]:=
coloredSpecToHypergraph[spec:coloredSpecPattern]:=TakeList[Range[Length[Catenate[spec]]],Length/@spec]~Join~Select[FreeQ[h]]@Transpose[{Range[Length[Catenate[spec]]],Catenate[spec]}]
In[]:=
coloredSpecToHypergraph[OrderedNet[{_,e:coloredSpecPattern}]]:=coloredSpecToHypergraph[e]
In[]:=
coloredRuleToHypergraph[in:coloredSpecPatternout:coloredSpecPattern]:=Module[{hairPositions,hairRules,outIndexToHair,hairToInIndex,outToInMapping},hairPositions=Position[Catenate[#],_h,{1}]〚All,1〛&/@{in,out};hairRules=Thread[Catenate[{in,out}〚#〛]〚hairPositions〚#〛〛hairPositions〚#〛]&/@{1,2};outIndexToHair=Association[Reverse/@hairRules〚2〛];hairToInIndex=Association[hairRules〚1〛];outToInMapping=Association[(#+Length[Catenate[in]])hairToInIndex[outIndexToHair[#]]&/@Keys[outIndexToHair]];coloredSpecToHypergraph[in](coloredSpecToHypergraph[out]+Length[Catenate[in]]/.outToInMapping)]
In[]:=
coloredRuleToHypergraph[OrderedNet[{_,in:coloredSpecPattern}]out_]:=coloredRuleToHypergraph[inout]
In[]:=
coloredRuleToHypergraph[in_OrderedNet[{_,out:coloredSpecPattern}]]:=coloredRuleToHypergraph[inout]
In[]:=
hypergraphToColoredSpec[edges_,hairVertices_:Automatic]:=Module[{threeEdges,verticesToIndices,twoEdges,indexRelations,hairlessSpec,hairPositions,hairs},threeEdges=Cases[edges,{_,_,_},{1}];verticesToIndices=Association[Thread[Catenate[threeEdges]Range[Length[Catenate[threeEdges]]]]];twoEdges=Cases[edges,{_,_},{1}];indexRelations=Select[OrderedQ]@Map[verticesToIndices,twoEdges,{2}];hairlessSpec=Partition[Permute[Range[Length[Catenate[threeEdges]]],Cycles[indexRelations]],3];hairPositions=If[hairVertices===Automatic,Position[Partition[Range[Length[Catenate[threeEdges]]],3]-hairlessSpec,0],Position[threeEdges,#]〚1〛&/@hairVertices];hairs=h/@Range[Length[hairPositions]];ReplacePart[hairlessSpec,Thread[hairPositionshairs]]]
In[]:=
hypergraphRuleToColored[in_out_]:=With[{hairVertices=Intersection[Catenate[in],Catenate[out]]},Rule@@(hypergraphToColoredSpec[#,hairVertices]&/@{in,out})]
In[]:=
unorderedToOrderedHypergraph[edges_]:=Catenate@MapIndexed[Thread[{e[#2〚1〛],#}]&,edges]
Exploration
Exploration
In[]:=
finalStates[rules_][steps_]:=finalStates[rules][steps]=ParallelMapMonitored[WolframModel[coloredRuleToHypergraph@#,coloredSpecToHypergraph@{{4,5,6},{1,2,3}},steps]@"FinalState"&,rules]
In[]:=
finalStatesPlots[rules_][steps_]:=finalStatesPlots[rules][steps]=ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec@#,VertexShapeFunction"Circle",VertexSize0,VertexStyleTransparent]&,finalStates[rules]@steps]
In[]:=
finalStatesPlot[rules_][steps_]:=First@finalStatesPlots[{rules}]@steps
In[]:=
distinctStateProducingRules[rules_][steps_]:=distinctStateProducingRules[rules][steps]=First/@DeleteDuplicates[Transpose@{rules,finalStatesPlots[rules]@steps},IsomorphicGraphQ@@SimpleGraph/@Last/@{##}&]
In[]:=
colorIndependentRule[rule_]:=WolframModel[{{1,2,3}}{{0,1},{0,2},{0,3}},"VertexNamingFunction"None]/@coloredRuleToHypergraph@rule
In[]:=
distinctRuleShapes[rules_]:=distinctRuleShapes[rules]=First/@DeleteDuplicatesBy[Last]@Transpose@{rules,ParallelMapMonitored[FindCanonicalWolframModel@*colorIndependentRule,rules,"Label""canonicalization"]}
Enumeration
Enumeration
In[]:=
GraphicsGrid@Partition[finalStatesPlots[$rewritesOrdered24h4]@4,UpTo@15]
Out[]=