2048 的 mathematica 实现与改良

闲来无事，我扒出了十年前在网上复制粘贴的mma2048代码，并对其进行了改良，将2048与Threes!结合起来：

（由于涉及键盘操作，网页版的编译器无法操作，请自行下载mma8.0及以上版本运行）

原先的 2048，mathematica 实现如下：

挪[左] = # //. {{x___, 1, a_ /; a > 1, y___} :> {x, a, 1, y}, {x___, 
        a_ /; a > 1, a_, y___} :> {x, 2 抓住[a], 1, y}} /. 抓住[a_] :> a &;
挪[上] = Composition[Transpose, 挪[左], Transpose];
挪[下] = Composition[Reverse, 挪[上], Reverse];
挪[右] = Composition[Transpose, 挪[下], Transpose];
加块瓦 = ReplacePart[#, 
    RandomChoice@Position[#, 1] -> RandomChoice[{2, 4}]] &;
按键 = If[格子 != 挪[#][格子], 格子 = 加块瓦[挪[#][格子]]; 总分 = Total[Total[格子]];
    Which[And @@ (格子 == 挪[#][格子] & /@ {左, 右, 上, 下}), 
     状态 = "你的得分为" ToString[总分]]] &;
格子 = 加块瓦[ConstantArray[1, {4, 4}]];
状态 = "";
EventHandler[
 Dynamic[ArrayPlot[Log2@格子/17, ColorFunction -> Hue, 
   ColorFunctionScaling -> False, Mesh -> All, 
   Epilog -> {MapIndexed[
      Text[If[#1 == 1, "", Style[#1, "Section"]], #2 - {0.5, 0.5}] &, 
      Transpose@Reverse@格子, {2}], 
     Text[Style[状态, Blue, 24], {2, 2}]}]], {"LeftArrowKeyDown" :> 
   按键[左], "RightArrowKeyDown" :> 按键[右], "UpArrowKeyDown" :> 按键[上], 
  "DownArrowKeyDown" :> 按键[下]}]

我在其基础上结合了 Threes! 的规则，这里 1 只能和 2 合并，2 也只能与 1 合并，然后 3 + 3 = 6，6 + 6 = 12，就跟 2048 的规则一样了。代码随机生成 1，2，3 中的任意块且概率相等。最终的计分规则为对于大于 3 的块的计分，以 3，9，27 的指数级递增，最后求和。与原版 Threes! 区别是移动规则不是一格一格移动，以及没有随机生成高分块的特性。修改的代码如下：

挪[左] = # //. {{x___, 1, a_ /; a > 1, y___} :> {x, a, 1, y}, {x___, 2, 
       4, y___} :> {x, 6, 1, y}, {x___, 4, 2, y___} :> {x, 6, 1, 
       y}, {x___, a_ /; a >= 6 && EvenQ[a], a_, y___} :> {x, 2 a, 1, 
       y}} &;
挪[上] = Composition[Transpose, 挪[左], Transpose];
挪[下] = Composition[Reverse, 挪[上], Reverse];
挪[右] = Composition[Transpose, 挪[下], Transpose];
加块瓦 = ReplacePart[#, 
    RandomChoice@Position[#, 1] -> RandomChoice[{2, 4, 6}]] &;
计算分数 = Total[If[# >= 6, 3^Log2[#/3], 0] & /@ Flatten[#]] &;
按键 = If[格子 != 挪[#][格子], 格子 = 加块瓦[挪[#][格子]];
    总分 = 计算分数[格子];
    Which[And @@ (格子 == 挪[#][格子] & /@ {左, 右, 上, 下}), 
     状态 = "游戏结束！得分：" <> ToString[总分]]] &;
格子 = 加块瓦[ConstantArray[1, {4, 4}]];
状态 = "";
EventHandler[
 Dynamic[ArrayPlot[Log2@格子/17, ColorFunction -> Hue, 
   ColorFunctionScaling -> False, Mesh -> All, 
   Epilog -> {MapIndexed[
      Text[If[#1 == 1, "", Style[#1/2, "Section"]], #2 - {0.5, 0.5}] &,
       Transpose@Reverse@格子, {2}], 
     Text[Style[状态, Blue, 20], {2, 2}]}]], {"LeftArrowKeyDown" :> 
   按键[左], "RightArrowKeyDown" :> 按键[右], "UpArrowKeyDown" :> 按键[上], 
  "DownArrowKeyDown" :> 按键[下]}]

随便打了一局，得了 3078 分，感觉还是有一定可玩性。