In[]:=
bullvalene=Molecule["C\\2=C\\C/1\\C=C/C3C(\\C=C\\1)C/23"]//MoleculeModify["ComputeAtomCoordinates"];​​patt=MoleculePattern[{"C","C","C","C","C","C"},{Bond[{1,2},"Double"],Bond[{2,3},"Single"],Bond[{3,4},"Single"],Bond[{4,5},"Single"],Bond[{5,6},"Double"]}];​​repl=Molecule[{"C","C","C","C","C","C"},{Bond[{1,2},"Single"],Bond[{2,3},"Double"],Bond[{1,6},"Single"],Bond[{4,5},"Double"],Bond[{5,6},"Single"]}];
In[]:=
mutateBullvalene[bull_,patt_,repl_]:=Module[​​{match,bondMatches,lhs,rhs},​​match=RandomChoice[PacletSymbol["WolframChemistry/ChemistryFunctions","MoleculeSubstructureMatches"][bull,patt,All]];​​lhs=Bond[{OrderlessPatternSequence@@#},_]&/@match["Bonds"];​​rhs=ReplaceAll[​​BondList[repl,IncludeHydrogens->"ExplicitOnly"],​​Thread[Range[Length@match["Atoms"]]->match["Atoms"]]​​];​​Molecule[​​AtomList[bull],​​ReplaceAll[BondList[bull],Thread[lhs->rhs]],​​AtomCoordinates->bull["AtomCoordinates"]​​]​​]
With that function written we can make a sequence of random replacements and try to make a movie
In[]:=
res=CreateDataStructure["DynamicArray"];​​temp=bullvalene;​​res["Append",temp];​​Do[​​temp=mutateBullvalene[temp,patt,repl];​​res["Append",temp];​​temp=MoleculeModify[temp,"EnergyMinimizeAtomCoordinates"];​​res["Append",temp],​​{n,30}​​]
In[]:=
x={-0.365541,-1.36418,3.07496};​​plots=MoleculePlot3D[#,ViewPointx,SphericalRegionTrue]&/@Normal[res];​​FrameListVideo[plots]
Out[]=
The video is very jumpy, between frames the atoms will move quite a bit due to the force-field energy minimization. We can smooth it by interpolating between frames
In[]:=
res=CreateDataStructure["DynamicArray"];​​in=bullvalene;​​res["Append",in];​​Do[​​in=mutateBullvalene[in,patt,repl];​​optimized=MoleculeModify[in,"EnergyMinimizeAtomCoordinates"];​​{coords1,coords2}=MoleculeValue[{in,optimized},"AtomCoordinates",TargetUnits->None];​​diff=coords2-coords1;​​res["Append",Molecule[in,AtomCoordinates->(coords1+#*diff)]]&/@Range[0,1,.05];​​in=optimized,​​{n,30}​​]
In[]:=
x={-0.365541,-1.36418,3.07496};​​plots=MoleculePlot3D[#,ViewPointx,SphericalRegionTrue]&/@Normal[res];
Using this interpolation step gives a nice animation
In[]:=
FrameListVideo[Reverse@plots]
Out[]=