本文为2048游戏 2D与3D版本的mathematica实现, code is here
2D情况


3D情况

似乎如果不放文字代码就会乱码

Clear["Global`*"];
SetOptions[Graphics3D, Boxed -> False, Axes -> False, 
  ViewPoint -> {2.13, -0.69, 2.53}, Lighting -> "Neutral", 
  Method -> {"CylinderPoints" -> 7, "TubePoints" -> 7}];
$empty = "";
newTile[board_] := 
  With[{pos = Position[board, $empty]}, 
   If[pos === {}, {}, {RandomChoice[{0.9, 0.1} -> {2, 4}], 
     RandomChoice@pos}]];
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 2D*)

drawTile[$empty, {none1_, none2_}, 2] = 
  Graphics[{$emptyColor, Rectangle[RoundingRadius -> 0.05]}];
drawTile[n__Integer, {none1_, none2_}, 2] := Graphics[{
    colorForNumber[n, "Background"], 
    Rectangle[{-1/2, -1/2}, RoundingRadius -> 0.05], 
    colorForNumber[n, "Color"], 
    Text@Style[n, Bold, FontFamily -> "Helvetica", 
      FontSize -> 
       Scaled[Switch[IntegerLength[n], 1 | 2, .5, 3, .4, _, .34]]]}];
drawGrid[board_, 2] := 
  Framed[GraphicsGrid[Map[drawTile[#, {0, 0}, 2] &, board, {2}], 
    ImageSize -> 250], FrameMargins -> 10, 
   Background -> $backgroundColor, RoundingRadius -> 10, 
   FrameStyle -> None];

$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 -> 80, 
    Background -> colorForNumber[n, "Background"]];
someelement[x0_, y0_, z0_, x1_, y1_, z1_, 
   r_] := {Polygon[{{x1, y0 + r, z0 + r}, {x1, y1 - r, z0 + r}, {x1, 
      y1 - r, z1 - r}, {x1, y0 + r, z1 - r}}],
   Polygon[{{x0 + r, y0, z0 + r}, {x1 - r, y0, z0 + r}, {x1 - r, y0, 
      z1 - r}, {x0 + r, y0, z1 - r}}], 
   Polygon[{{x0 + r, y1, z0 + r}, {x1 - r, y1, z0 + r}, {x1 - r, y1, 
      z1 - r}, {x0 + r, y1, z1 - r}}],
   Polygon[{{x0, y0 + r, z0 + r}, {x0, y1 - r, z0 + r}, {x0, y1 - r, 
      z1 - r}, {x0, y0 + r, z1 - r}}],
   Table[Tube[{{x0 + r, y, z1 - r}, {x1 - r, y, z1 - r}}, 
     r], {y, {y0 + r, y1 - r}}],
   Table[Tube[{{x, y0 + r, z1 - r}, {x, y1 - r, z1 - r}}, 
     r], {x, {x0 + r, x1 - r}}],
   Table[Cylinder[{{x, y, z0 + r}, {x, y, z1 - r}}, 
     r], {x, {x0 + r, x1 - r}}, {y, {y0 + r, y1 - r}}]};
drawTile[n_, pos_, 3] := drawTile[n, pos, 3] =
   Module[{x0, y0, z0, x1, y1, z1, r},
    {{x0, y0}, {x1, y1}} = pos - # & /@ {0.45, -0.45}; z0 = -.2; 
    z1 = Log[2, n]/11; r = 1/16;
    Graphics3D[{EdgeForm@None, 
      colorForNumber[n, "Background"], {Texture[$textures[n]], 
       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}}]}, someelement[x0, y0, z0, x1, y1, z1, r]}]
    ];
drawTile[$empty, pos_, 3] := drawTile[$empty, pos, 3] =
   Module[{x0, y0, z0, x1, y1, z1, r},
    {{x0, y0}, {x1, y1}} = pos - # & /@ {0.45, -0.45}; z0 = -.2; 
    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}}],
      someelement[x0, y0, z0, x1, y1, z1, r]}]
    ];

(*cache*)
$textures[2^#] & /@ Range[11];
Table[drawTile[num, {i, j}, 3], {num, 
   Flatten[{2^Range[11], $empty}]}, {i, 4}, {j, 4}];

drawBottom = 
  Graphics3D[{$backgroundColor, 
    Cuboid[{0.4, 0.4, -0.1}, {4.6, 4.6, 0}]}];
drawGrid[board_, 3] := 
  Show[drawBottom, 
   Table[drawTile[board[[i, j]], {i, j}, 3], {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"];

combineLeft[l_] := 
  Flatten[Cases[
     l, _Integer] //. {a___, x_Integer, x_Integer, 
      b___} :> (Sow[x + x]; {a, {x + x}, b})];
combineRight[l_List] := Reverse@combineLeft@Reverse[l];
shift[board_, "Left"] := 
  PadRight[combineLeft@#, Length@board, $empty] & /@ board;
shift[board_, "Right"] := 
  PadLeft[combineRight@#, Length@board, $empty] & /@ board;
shift[board_, "Up"] := Transpose[shift[Transpose@board, "Left"]];
shift[board_, "Down"] := Transpose[shift[Transpose@board, "Right"]];
matchesAvailable[board_] := 
  Or @@ (Cases[#, {___, x_Integer, 
         x_Integer, ___}, {1}] =!= {} & /@ {board, 
      Transpose[board]});
movesAvailable[board_] := ! FreeQ[board, $empty] || 
   matchesAvailable[board];

newboard[size_] := 
  Module[{board = Table[$empty, {size}, {size}]}, 
   Do[(board[[Sequence @@ #2]] = #1) & @@ newTile[board], {2}];
   board];
start2048[] := With[{size = 4},
   CreateDialog[
    DynamicModule[{board = newboard[size], tile, score = 0, s, 
      oldBoard, gameover = False, won = False, d},
     Dynamic@Column@
       {Row@{Button[
           "Reset", (board = newboard[size]; score = 0; 
            gameover = False; won = False), ImageSize -> {100, 50}],
          Spacer[70], 
          RadioButtonBar[
           Dynamic@d, {2 -> Style["2D", 20], 3 -> Style["3D", 20]}]}, 
        Row@{Which[gameover, 
            Overlay[{#, 
               Text[Style["Gameover", Red, Bold, 
                 FontFamily -> "Helvetica", 
                 FontSize -> Scaled[0.1]]]}, Alignment -> Center] &, 
            won, Overlay[{#, 
               Text[Style["You win!", Yellow, Bold, 
                 FontFamily -> "Helvetica", 
                 FontSize -> Scaled[0.1]]]}, Alignment -> Center] &, 
            True, Identity]@drawGrid[board, d], Spacer[50], 

          Column[{Style[score, Bold, colorForNumber[2, "Color"], 
             FontFamily -> "Helvetica", FontSize -> 50], 
            Show[drawTile[Max[board /. $empty -> 0], {0, 0}, d], 
             ImageSize -> 100]}, Alignment -> Center, Spacings -> 5]}},
     Initialization :> (
       handle[key_] :=
        If[! gameover && ! won,
         oldBoard = board; {board, s} = Reap[shift[board, key]];
         If[
          board =!= oldBoard, (board[[Sequence @@ #2]] = #1) & @@ 
           newTile[board]];
         If[s =!= {}, score += Total[s[[1]]]];
         Which[Max[board /. $empty -> 0] >= 2048, 
          won = True, ! movesAvailable[board], gameover = True]
         ];
       SetOptions[EvaluationNotebook[], 
        NotebookEventActions -> {"LeftArrowKeyDown" :> (handle[
             "Left"]), "RightArrowKeyDown" :> handle["Right"], 
          "UpArrowKeyDown" :> handle["Up"], 
          "DownArrowKeyDown" :> handle["Down"]}])
     ], WindowSize -> {800, 600}, Background -> White]];
start2048[]