1
$\begingroup$

My goal is to generate a graph from a 3D isotropic array of vertex connected tetrahedrons. Each tetrahedron represents a node of my graph, and connects to 4 other neighbors. Then my idea is to simulate discrete markov processes from that graph, with each tetrahedron node having the same probability table.

My biggest problem, and I can't find a way around it, is that I would like to generate a graph from a lattice. Is that actually possible? The graph I would like to generate would be a representation of a tetrahedral lattice, like: lattice = LatticeData["TetrahedralPacking", "Image"]; Graphics3D[ Translate[DeleteCases[lattice, {_, _, Polygon[_]}, Infinity][[1]], 2 Tuples[Range[3], 3]], Boxed -> False]

once I manage to do that, I should be good with the rest of the process!

Could anyone of you help me out with this? Hoping my explanation was clear enough.

$\endgroup$
  • 2
    $\begingroup$ This seems a bit of a tall order. What have you tried so far? $\endgroup$ – MarcoB Mar 24 '16 at 19:53
  • $\begingroup$ Hi Marco, thanks for your response! Mhh so far I just found that the graph I want to generate would originate from a TetrahedralPacking lattice: cell = LatticeData["TetrahedralPacking", "Image"] $\endgroup$ – Alexis C Mar 24 '16 at 20:53
  • $\begingroup$ I know how to generate Markov Processes, Graphs, Lattices, but I'm trying to put pieces together! FYI I am a total newbie in mathematica ;) $\endgroup$ – Alexis C Mar 24 '16 at 20:58
  • 1
    $\begingroup$ If you know some of the pieces, then you'll have to provide the code for those pieces and be more specific about what stumbling blocks you encountered in putting them together. Writing it all from scratch for you is not usually the type of thing for which this site is intended. $\endgroup$ – Jens Mar 24 '16 at 21:34
  • $\begingroup$ Hi Jens, Thanks a lot for your answer. I am really not waiting for any of you to write code for me, but rather was looking for some help because I couldn't find the solution anywhere. I apologize if I sounded like I did. $\endgroup$ – Alexis C Mar 25 '16 at 23:14
2
$\begingroup$

Maybe this can help get you started. I haven't attempted to deal with expanding the lattice size yet.

Taking just the basic lattice image:

    LatticeData["TetrahedralPacking", "Image"]

enter image description here

We just want the connectivity of the vertices, which is described by the Lines:

    lines = Cases[LatticeData["TetrahedralPacking", "Image"], Line[_], \[Infinity]]

And just convert them into UndirectedEdges:

    g = Graph[UndirectedEdge @@@ lines[[1, 1]]]

enter image description here

For a repeating Lattice:

The approach is to duplicate the lattice points, labelling them new vertex number as we go. Then find use Merge to find where we have multiple points at the same coordinate, keep only the lowest index and replace the other indices appropriately.

First get the Lattice data and the coordinates of the vertices from the GraphicsComplex:

ld = LatticeData["TetrahedralPacking", "Image"]
gc = First@Cases[ld, GraphicsComplex[___], \[Infinity]]

vertexCoords = gc[[1]]

{{-1, -1, -1}, {-1, -1, 1}, {-1, 1, -1}, {-1, 1, 1}, {1, -1, -1}, {1, -1, 1}, {1, 1, -1}, {1, 1, 1}, {0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {-1, 0, 0}, {0, 0, -1}, {0, -1, 0}, {1/2, 1/2, 1/ 2}, {-(1/2), -(1/2), 1/2}, {1/2, -(1/2), -(1/2)}, {-(1/2), 1/ 2, -(1/2)}}

nVertices = Length[vertxCoords]

18

vertexConnections = Cases[gc, Line[___], \[Infinity]][[1, 1]]

{{15, 8}, {15, 9}, {15, 11}, {15, 10}, {16, 9}, {16, 2}, {16, 12}, {16, 14}, {17, 10}, {17, 14}, {17, 13}, {17, 5}, {18, 11}, {18, 12}, {18, 13}, {18, 3}}

Setup our list of shifts:

shifts = 2 Tuples[Range[0, 2], 3];

{{0, 0, 0}, {0, 0, 2}, {0, 0, 4}, {0, 2, 0}, {0, 2, 2}, {0, 2, 4}, {0, 4, 0}, {0, 4, 2}, {0, 4, 4}, {2, 0, 0}, {2, 0, 2}, {2, 0, 4}, {2, 2, 0}, {2, 2, 2}, {2, 2, 4}, {2, 4, 0}, {2, 4, 2}, {2, 4, 4}, {4, 0, 0}, {4, 0, 2}, {4, 0, 4}, {4, 2, 0}, {4, 2, 2}, {4, 2, 4}, {4, 4, 0}, {4, 4, 2}, {4, 4, 4}}

Then create a table of Associations with vertexCoord->vertexLabel for all the shifts sets:

tab = Table[
  Association@Thread[
   (TranslationTransform[shifts[[i]]] /@ vertexCoords) -> 
   Range[(i - 1) nVertices + 1, i nVertices]
  ]
 , {i, Length[shifts]}
];

Group the vertexLables by the vertexCoords:

m = Merge[tab, List];

and create a list of replacement rules for all the duplicated vertices:

repRule[list_] := Rule[#, First[list]] & /@ Rest[list]
rules = Flatten[repRule /@ Flatten[Values[m], 1]]

Finally to get the connectivity of the vertices, just shift the labels of the original connectivity and apply our replacement rules:

vexPairs = Flatten[
    Table[vertexConnections + nVertices i , {i, 0, Length[shifts] - 1}], 
  1] /. rules;

g = Graph[UndirectedEdge @@@ vexPairs]

enter image description here

Then obviously we can use the graph g to simulate Markov processes etc:

dmp = DiscreteMarkovProcess[UnitVector[VertexCount[g], RandomInteger[{1, VertexCount[g]}]], g];
MarkovProcessProperties[dmp]

enter image description here

We can check that it looks correct in 3D space:

Graphics3D[
 GraphicsComplex[
  Keys[m],
  {
   Sphere[#, 0.06] & /@ Range[Length[Keys[m]]],
   {GrayLevel[0.7], 
    Line[vexPairs /. 
      Thread[(First /@ Flatten[Values[m], 1]) -> 
        Range[Length[Keys[m]]]]]}
   }
  ],
 Boxed -> False
 ]

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ Amazing! That was exactly what I was looking for and was blocking on! Thanks so much Quantum_Oli! $\endgroup$ – Alexis C Mar 28 '16 at 0:27
  • $\begingroup$ Hi Quantum_Oli thank you very much for this it's been most helpful! Do you know how you could generate this same crystal but about twice as big in each dimension, ie so it contains 8 times as many nodes? I'm new to Mathmatica so struggling to find a way. $\endgroup$ – Joseph Welford Mar 12 '18 at 15:24

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.