7
$\begingroup$

How do I modify the following program to create a nice coloured molecular plot of C60 or fullerene as shown in the attached figure

enter image description here

This figure was retrieved from http://asserttrue.blogspot.com.au/2013/03/olive-oil-fullerene-and-lifespan.html#

pos = {{4.20790955, 1.12423579, 5.0724025}, {5.92255243, 0.30577656, 
    3.09053347}, {2.53625794, -0.58931105, 6.15449739}, 
       {5.89150423, -2.19125067,  2.27598598}, {6.07911622, -2.76287388, -0.40300296}, {6.14208189, 2.34350589, 1.26288498}, 
       {6.32168145, 1.79658139, -1.30022597}, {6.28972619, -0.81331917, -2.15152863}, {-0.85451519, 2.59699373, 6.10424958}, 
       {0.89249869, 4.38777367, 4.97351314}, {-0.0510226, 0.16353689, 
    6.68186323}, {3.36781297, 3.66786366, 4.46912637}, 
       {4.56285678, 4.42127851, 2.11483015}, {-1*0.4993034, 
    5.8930727, 3.14654495}, {0.64416979, 6.61402206, 0.89416165}, 
       {3.23137475, 5.86189222, 
    0.36707927}, {-4.0468482, -1.59965305, 5.07597408}, {-4.88658574, 
    0.94354019, 4.47250898}, 
       {-1.6827443, -1.98120762, 6.15625484}, {-3.32578546, 
    2.99557474, 4.97542176}, {-3.10623709, 5.03232141, 3.14743312}, 
       {-6.29775752, 0.83554235, 2.119271}, {-6.08784676, 2.78439786, 
    0.37044299}, {-4.45682426, 4.92933134, 0.89618365}, 
       {-0.95746747, -5.66581425, 
    3.40868774}, {-3.4282275, -5.26727104, 
    2.27991661}, {-0.10387824, -4.05947157, 5.30402621}, 
       {-4.93898784, -3.27912812, 
    3.09521999}, {-6.32980727, -1.77424483, 
    1.26783606}, {-3.2399919, -5.83991471, -0.39909123}, 
       {-4.57094481, -4.40022696, -2.14742792}, {-6.15020772, 
-2.32243545, -1.29533158}, {4.14416909, -3.98220068, 3.40634448}, 
       {3.25204835, -5.66116553, 
    1.42568487}, {2.50352789, -3.19913602, 
    5.30279789}, {0.75764784, -6.48459473, 1.4268754}, 
       {-0.65282474, -6.59204455, -0.92630589}, {4.44820711, \
-4.90778847, -0.92840348}, {3.0986026, -5.01057066, -3.17986082}, 
       {0.4916878, -5.87162431, -3.17872698}, {-4.21537397, \
-1.1041291, -5.10475461}, {-3.37499392, -3.64732234, -4.50151628}, 
       {-0.8993395, -4.36660874, -5.00582745}, {-2.5441003, 
    0.61009804, -6.18628259}, {-4.15359883, 4.00310105, -3.4385832}, 
       {-5.90029145, 
    2.21167861, -2.30835699}, {-5.93067825, -0.2855187, -3.12307455}, \
{-2.51263637, 3.22020647, -5.33473426}, 
       {0.94767869, 5.68830199, -3.44022726}, {-0.76728544, 
    6.50657224, -1.4586417}, {-3.26164816, 5.6827084, -1.45786691}, 
       {0.09442961, 4.08156247, -5.33543346}, {4.03843892, 
    1.62287778, -5.10734353}, {4.93027621, 3.30214499, -3.126854}, 
       {3.41902454, 5.29011783, -2.3116829}, {1.67416495, 
    2.00384654, -6.18737863}, {0.847561, -2.57503512, -6.13588359}, 
       {3.3185856, -2.97318149, -5.00728254}, {4.87893235, \
-0.92061781, -4.50446425}, {0.0434637, -0.14161607, -6.7131004}}; 
atype = {"C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", 
   "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", 
       "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", 
   "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", 
   "C", "C", "C", "C", "C", "C", "C", "C", "C", "C"}; 
dataC = AssociationThread[Range[Length[atype]], 
   Transpose[{atype, pos}]]; 
writeXYZ[file_String, data_] := 
 Module[{str = OpenWrite[file, FormatType -> OutputForm], 
   len = Length[data]}, 
     Scan[
   WriteLine[str, #1] & , {ToString[len], 
    "            Coordinates (Angstroms)"}]; 
      Scan[Write[str, "    ", data[#1][[1]], 
     PaddedForm[data[#1][[2, 1]], {14, 6}], 
     PaddedForm[data[#1][[2, 2]], {10, 6}], 
            PaddedForm[data[#1][[2, 3]], {10, 6}]] & , Range[len]]; 
  Close[str]]
writeXYZ["testC.xyz", dataC]; 
Import["testC.xyz", "XYZ"]
$\endgroup$
5
  • $\begingroup$ There is a nice built-in function ChemicalData["FullereneC60", "MoleculePlot"] $\endgroup$
    – ybeltukov
    Sep 19, 2014 at 20:59
  • $\begingroup$ Not to mention: demonstrations.wolfram.com/… $\endgroup$
    – Igor Rivin
    Sep 19, 2014 at 21:01
  • $\begingroup$ @ybeltukov Yes that built-in function is gd, but really need differentiation in bonds/atoms via colours $\endgroup$
    – thils
    Sep 19, 2014 at 21:16
  • 1
    $\begingroup$ The output from the built-in MoleculePlot is just a Graphics3D expression with spheres for the atoms and cylinders for the bonds. So use something like % /. {c_Cylinder :> Style[c, Red], s_Sphere :> Style[s, Blue]} $\endgroup$ Sep 19, 2014 at 21:30
  • $\begingroup$ As written, your coordinates are actually in Bohr, so you need to convert to angstroms. This uses your coordinates, but doesn't get differently colored bonds: ImportString[ ExportString[Transpose[Join[{atype}, Transpose@(0.529177 pos)]], "Table"], "XYZ"] /. {Cylinder[a__] :> {Yellow, Cylinder[a]}, Sphere[a__] :> {Blue, Sphere[a]}} $\endgroup$
    – Jason B.
    Feb 18, 2016 at 14:30

1 Answer 1

12
$\begingroup$

One can colorize bonds by finding 5-cycles in the bounding graph

pts = QuantityMagnitude@ChemicalData["FullereneC60", "AtomPositions"];
graph = UndirectedGraph@Graph@ChemicalData["FullereneC60", "EdgeRules"];
ring5 = List @@@ Flatten@FindCycle[graph, {5}, 12];
remain = Complement[List @@@ EdgeList[graph], ring5, ring5[[All, {2, 1}]]];

Graphics3D@GraphicsComplex[pts, {Blue, Ball[Range@60, 30], Red, Tube[ring5, 10], Yellow, 
   Tube[remain, 10]}]

enter image description here

For version 9 and earlier you should delete QuantityMagnitude@.


After tuning the lightning

Graphics3D[GraphicsComplex[pts, {Specularity[White, 20], Lighter@Blue, Ball[Range@60, 30], 
  Red, Tube[ring5, 10], Yellow, Tube[remain, 10]}], Boxed -> False, 
 Background -> Black, Lighting -> {{"Ambient", GrayLevel[0.2]}, {"Directional", 
    GrayLevel[0.8], {{0, 0, 0}, {-1, 0, -1.5}}}}]

enter image description here

$\endgroup$
3
  • $\begingroup$ How to add lighting effects...see original pic $\endgroup$
    – thils
    Sep 19, 2014 at 21:45
  • 1
    $\begingroup$ @thils See my update :) $\endgroup$
    – ybeltukov
    Sep 19, 2014 at 22:03
  • 1
    $\begingroup$ NB in v9 FindCycle[] is still a Combinatorica function $\endgroup$ Sep 19, 2014 at 22:55

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.