Poor performance from Graphics3D

Question

I wrote a game -- 2048，Some codes are from http://blog.wolfram.com/. My codes are in notebook downloads

I added code so that the game can play in 3D form, but when I play it, I find that it is too slow, so I write some test code to investigate performance.

The front end seems to be too slow to update the complex 3D graphics in real time. How can I deal with this?

Edit 1: The main relevant codes

Clear["Global`*"];
SetOptions[Graphics3D, Boxed -> False, Axes -> False];
$empty = "";

colors = {"Color" -> #1, "Background" -> #2} & @@@ {{"#776e65", 
 "#eee4da"}, {"#776e65", "#ede0c8"}, {"#f9f6f2", 
 "#f2b179"}, {"#f9f6f2", "#f59563"}, {"#f9f6f2", 
 "#f67c5f"}, {"#f9f6f2", "#f65e3b"}, {"#f9f6f2", 
 "#edcf72"}, {"#f9f6f2", "#edcc61"}, {"#f9f6f2", 
 "#edc850"}, {"#f9f6f2", "#edc53f"}, {"#f9f6f2", "#edc22e"}};
hexToRGB[s_String] := 
  RGBColor @@ (IntegerDigits[FromDigits[StringTake[s, -6], 16], 256, 3]/255.);
colorForNumber[n_Integer, s_] := hexToRGB[s /. colors[[Log[2, n]]]];
$emptyColor = RGBColor[0.75436, 0.701427, 0.642634];
$backgroundColor = RGBColor[0.676677, 0.616403, 0.559747];

(*draw 3D*)
drawTile[n_Integer, pos_: {0, 0}] := 
 Module[{texture, x0, y0, z0, x1, y1, z1, r},
   {{x0, y0}, {x1, y1}} = pos - # & /@ {0.45, -0.45};
   z0 = -.1; z1 = Log[2, n]/11; r = 1/16;
   texture = 
   Graphics[{colorForNumber[n, "Background"], 
     Polygon[{{-0.45, -0.45}, {-0.45, 0.45}, {0.45, 0.45}, {0.45, -0.45}}], 
     Text[Style[n, Bold, FontFamily -> "Helvetica", 
     FontSize -> Scaled@Switch[IntegerLength@n, 1 | 2, .5, 3, .4, _, .34], 
     colorForNumber[n, "Color"]]]}, PlotRangeClipping -> True, PlotRange -> 0.4];
  Graphics3D[{EdgeForm@None, 
     colorForNumber[n, "Background"], {Texture@texture, 
     Polygon[{{x0 + r, y0 + r, z1}, {x1 - r, y0 + r, z1},
       {x1 - r, y1 - r, z1}, {x0 + r, y1 - r, z1}}, 
     VertexTextureCoordinates -> {{0, 1}, {0, 0}, {1, 0}, {1, 1}}]},
  Cuboid[{x0, y0, z0} + #, {x1, y1, z1} - #] & /@ {{0, r, r}, {r, 0, r}},
  Table[Tube[{{x0 + r, y, z}, {x1 - r, y, z}}, r], 
      {y, {y0 + r, y1 - r}}, {z, {z0 + r, z1 - r}}], 
  Table[Tube[{{x, y0 + r, z}, {x, y1 - r, z}}, r],
      {x, {x0 + r, x1 - r}}, {z, {z0 + r, z1 - r}}], 
  Table[Tube[{{x, y, z0 + r}, {x, y, z1 - r}}, r], 
       {x, {x0 + r, x1 - r}}, {y, {y0 + r, y1 - r}}]}]
 ];
drawTile[$empty, pos_: {0, 0}] := 
  Module[{texture, x0, y0, z0, x1, y1, z1, r},
   {{x0, y0}, {x1, y1}} = pos - # & /@ {0.45, -0.45}; 
  z0 = -.1; z1 = 1/22; r = 1/16;
  Graphics3D[{EdgeForm@None, $emptyColor, {Polygon[{{x0 + r, y0 + r, z1},
     {x1 - r, y0 + r, z1}, {x1 - r, y1 - r, z1}, {x0 + r, y1 - r, z1}}]},
    Cuboid[{x0, y0, z0} + #, {x1, y1, z1} - #] & /@ {{0, r, r}, {r, 0, r}},
    Table[Tube[{{x0 + r, y, z}, {x1 - r, y, z}}, r],
       {y, {y0 + r, y1 - r}}, {z, {z0 + r, z1 - r}}], 
    Table[Tube[{{x, y0 + r, z}, {x, y1 - r, z}}, r],
       {x, {x0 + r, x1 - r}}, {z, {z0 + r, z1 - r}}], 
    Table[Tube[{{x, y, z0 + r}, {x, y, z1 - r}}, r], 
       {x, {x0 + r, x1 - r}}, {y, {y0 + r, y1 - r}}]}]];
drawBottom = Graphics3D[{$backgroundColor, 
    Cuboid[{0.4, 0.4, -0.1}, {4.6, 4.6, 0}]}];
drawGrid[board_] := Show[drawBottom, 
   Table[drawTile[board[[i, j]], {i, j}], {i, 4}, {j, 4}], 
   PlotRange -> {{0.5, 4.5}, {0.5, 4.5}, {-0.05, 1}}, ImageSize -> 500, 
   ViewPoint -> {2.13, -0.69, 2.53}, Lighting -> "Neutral"];

I want to write the game -- 2048 in 3D form ,like this:

So First I need to plot the cuboid with rounded corners and texture.So I used Polygon,Text,Texture to realize the texture，and use Polygon,Cuboid,Cuboid to realize the cuboid with rounded corners.This is the function drawTile[].Then I just need to draw 16 cubes with function drawGrid[].And then the trouble is coming.The drawGrid contains a large number of primitives.It is quickly calculate in kernel.But if show it in the front end ，it will cost a long time that can not negligible.Here is the test codes.

data = Partition[RandomSample@PadLeft[2^# & /@ Range[11], 16, $empty],4];
m = AbsoluteTime[];
Show[drawGrid[data], ImageSize -> 150] // AbsoluteTiming
AbsoluteTime[] - m
m = AbsoluteTime[];
Show[drawGrid[data], ImageSize -> 150]; // AbsoluteTiming
AbsoluteTime[] - m

Actually when I press the arrow key ,it will be 0.5s delay before image update in 3D form games, while it will be less than 0.1s delay in 2D form games.My cpu is Intel Core i3 370M. I want to reduce the delay because 0.5s is too long.But now I have no idea.

Edit 2: new version of the program

notebook download

Edit 3: the advises from the original author of “2048 Wolfram Style”

I asked the original author to help me how to improve speed,and he give me three advises.It is very helpful!

1. Use graphics multi-primitives whenever you can. This means instead of writing something like {Sphere[point1, r], Sphere[point2, r]}, use {Sphere[{point1, point2}, r]}. This works with many graphics objects.
2. Use floating point arithmetic. This means instead of using 1/16 or Log[2, 5], use 1/16. or Log[2., 5.].
3. You could also try to Rasterize the textures and numbers in advance.

his advises

My lastest program can download here

Answer 1

One of the main bottlenecks in your code are the texture you apply on each surface. Try to use texture = {}; in your drawTile function and the graphics should be faster by magnitudes.

Additionally, as Yves mentioned, Tubes are a performance killer too.

Therefore, a workaround for your problem might be to Rasterize the texture graphics by yourself and use the smallest possible resolution which is acceptable for you.

I haven't looked at your complete implementation, but I guess you redraw (and therefore recreate) each tile when you play your game and use the arrow keys. What you then should do is to pre-render all needed textures. If I'm right then you only need all 2^n numbers on the surface which means with 11 images you have all needed graphics.

Therefore, a starting point is to define something like

$textures[n_] := ($textures[n] = 
   Rasterize[
    Graphics[{colorForNumber[n, "Background"], 
      Polygon[{{-0.45, -0.45}, {-0.45, 0.45}, {0.45, 
         0.45}, {0.45, -0.45}}], 
      Text[Style[n, Bold, FontFamily -> "Helvetica", 
        FontSize -> 
         Scaled@Switch[IntegerLength@n, 1 | 2, .5, 3, .4, _, .34], 
        colorForNumber[n, "Color"]]]}, PlotRangeClipping -> True, 
     PlotRange -> 0.4], RasterSize -> 40])

and setting texture = $textures[n]; in your drawTile function. Be careful not to Clear["Global`*"] because this also removes the memoization of your textures. With this each texture is only computed once.