11
|
3769 Views
|
5 Replies
|
15 Total Likes
View groups...
Share
GROUPS:

# [WSS22] Cellular automaton on Topological surfaces

Posted 1 year ago
5 Replies
Sort By:
Posted 8 months ago
 Excellent work, @Shuheng Li diagonalGridGraph[n_Integer, m_Integer] := With[ { g = NearestNeighborGraph[GraphEmbedding@GridGraph[{n, m}], DistanceFunction -> (ChessboardDistance)] }, VertexReplace[g, # -> -VertexIndex[g, #] & /@ VertexList[g]] ] torusGrid[n_Integer, m_Integer] := EdgeAdd[diagonalGridGraph[n, m], Union[ { Range[1, n][[#]] -> Range[n*m - m + 1, n*m][[#]], Range[1, n][[#]] -> Range[n*m - n + 1, n*m][[Mod[# + 1, n, 1]]], Range[1, n][[#]] -> Range[n*m - n + 1, n*m][[Mod[# - 1, m, 1]]] } & /@ Range[1, m] // Flatten, {Array[m*# - m + 1 &, m][[#]] <-> Array[n*# &, m][[#]], Array[n*# - n + 1 &, m][[#]] <-> Array[n*# &, m][[Mod[# + 1, m, 1]]], Array[n*# - n + 1 &, n][[#]] <-> Array[n*# &, n*m][[Mod[# - 1, m, 1]]]} & /@ Range[1, m] // Flatten] ] // SimpleGraph gliderLD[n_Integer, m_Integer, coordinate_List] := ReplacePart[ Array[0 &, n*m], {(coordinate[[2]] - 1)*n*m + coordinate[[1]] -> 1, (coordinate[[2]] - 1)*n + coordinate[[1]] + n + 1 -> 1, (coordinate[[1]] - 1)*n + coordinate[[2]] + 2 n - 1 -> 1, (coordinate[[1]] - 1)*n + coordinate[[2]] + 2 n -> 1, (coordinate[[1]] - 1)*n + coordinate[[2]] + 2 n + 1 -> 1}] listToGraph[g_Graph, state_List] := Graph[g, VertexStyle -> (If[ state[[#]] == 1, # -> Black, # -> ColorData["CherryTones"] /@ {RandomReal[]}] & /@ VertexList[g]), VertexSize -> 1] neighborPopulation[g_Graph, init_List] := Total[init[[#]] & /@ AdjacencyList[g, #]] & /@ VertexList[g] GSRule[g_Graph, init_List, survival_List, growth_List] := With[{N = neighborPopulation[g, init]}, If[init[[#]] == 0, If[MemberQ[growth, N[[#]]] == False, 1, 0], If[MemberQ[survival, N[[#]]] == True, 1, 0]] & /@ VertexList[g]] GSIterate[g_Graph, init_List, survival_List, growth_List, t_Integer] := NestList[GSRule[g, #, survival, growth] &, init, t] animate3D[g_Graph, init_List, survival_List, growth_List, t_Integer, speed_Integer : 1] := With[{A = Graph[listToGraph[g, #], VertexCoordinates -> Automatic] & /@ GSIterate[g, init, survival, growth, t]}, Animate[A[[u]], {u, 1, t + 1, speed}]] animate3D[torusGrid[15, 15], gliderLD[15, 15, {10, 10}], {2, 3, 4}, {3, 4}, 129, 1] On these topological surfaces, it's easy to get clogged full of random colors.
Posted 1 year ago
 Great work! I wonder if it will finally be possible to explore the behavior of general nearest-neighbor rules on such surfaces. Definition of such rules would require enumeration schemes for the grid. And maybe also the rules will become more complicated, for example, if the number of adjacent cells varies.You may also have a look at this post: https://community.wolfram.com/groups/-/m/t/2027803 It explores the behavior of totalistic cellular automata on 3D Lattices.
Posted 1 year ago
 Congrats, Shuheng, and thanks for putting in the work this month. How about making a semi-final revision of the underlying topological graphs and submitting them to WFR?
Posted 1 year ago
 Good idea, will definitely do that!
Posted 1 year ago
 -- you have earned Featured Contributor Badge Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!