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[]:=
ModRule[rule_]:=Module[{p={RandomInteger[{1,Length[rule]}],RandomInteger[{1,Length[First[rule]]}]},v,vp},v=Extract[rule,p];ReplacePart[rule,p(While[(vp=RandomInteger[MinMax[rule]];vp==v),Null];vp)]]
In[]:=
BuildNeighborPicture[{base_,nrules_}]:={If[#===Nothing,Return[{}],First[#]]&@ShowSamples[{base}],GraphicsGrid[Partition[Take[ShowSamples[nrules],UpTo[28]],14]]}
In[]:=
RuleNeighbors[sig_,n_Integer:20]:=Module[{base=FindBase[sig],nrules},nrules=DeleteDuplicates[Table[First[base]->ModRule[Last[base]],2n]];BuildNeighborPicture[{base,nrules}]{base,nrules}]
In[]:=
FindBase[sig_]:=Module[{r},While[(#{}||!ConnectedHypergraphQ[#])&@(WolframModelTest[r=RandomWolframModel[sig],Automatic]["FinalState"]),r];r]
FindBaseGeneric[sig_]:=Module[{r},While[(#{}||!ConnectedHypergraphQ[#])&@(WolframModelTest[r=RandomWolframModel[sig],Automatic]["FinalState"]),r];r]
RandomInteger[{1,18},{15,2}]
In[]:=
InteractiveListSelectorSW[Table[RuleNeighbors[{{2,2}}{{7,2}},50],4]]
Out[]=