2048 and Threes! written in mathematica

With some free time, I dug out the 2048 code written in mathematica that I copied and pasted from the internet ten years ago and modified it, combining 2048 with Threes!:

(Due to keyboard manipulation, the web-based compiler won't work. Please download mathematica version 8.0 or higher.)

Here is the original implementation of 2048 using wolfram language (mathematica):

MOVE[LEFT] = # //. {{x___, 1, a_ /; a > 1, y___} :> {x, a, 1, y}, {x___, 
        a_ /; a > 1, a_, y___} :> {x, 2 HOLD[a], 1, y}} /. HOLD[a_] :> a &;
MOVE[UP] = Composition[Transpose, MOVE[LEFT], Transpose];
MOVE[DOWN] = Composition[Reverse, MOVE[UP], Reverse];
MOVE[RIGHT] = Composition[Transpose, MOVE[DOWN], Transpose];
ADDBLOCK = ReplacePart[#, 
    RandomChoice@Position[#, 1] -> RandomChoice[{2, 4}]] &;
KEY = If[BLOCK != MOVE[#][BLOCK], BLOCK = ADDBLOCK[MOVE[#][BLOCK]]; SCORE = Total[Total[BLOCK]];
    Which[And @@ (BLOCK == MOVE[#][BLOCK] & /@ {LEFT, RIGHT, UP, DOWN}), 
     STATE = "Your score is " ToString[SCORE]]] &;
BLOCK = ADDBLOCK[ConstantArray[1, {4, 4}]];
STATE = "";
EventHandler[
 Dynamic[ArrayPlot[Log2@BLOCK/17, ColorFunction -> Hue, 
   ColorFunctionScaling -> False, Mesh -> All, 
   Epilog -> {MapIndexed[
      Text[If[#1 == 1, "", Style[#1, "Section"]], #2 - {0.5, 0.5}] &, 
      Transpose@Reverse@BLOCK, {2}], 
     Text[Style[STATE, Blue, 24], {2, 2}]}]], {"LeftArrowKeyDown" :> 
   KEY[LEFT], "RightArrowKeyDown" :> KEY[RIGHT], "UpArrowKeyDown" :> KEY[UP], 
  "DownArrowKeyDown" :> KEY[DOWN]}]

I've incorporated the rules of Threes!:

• Here, 1 can only merge with 2, and 2 can only merge with 1. However, 3 + 3 = 6, and 6 + 6 = 12, just like the rules of 2048.
• The code randomly generates blocks of 1, 2, or 3 with equal probability.
• The final scoring rule is to score blocks equal or greater than 3 with 3, 9, 27 ... and then sum them up.

The difference from the original Threes! is that:

• The movement rule is not one block at a time, it is still the rule from 2048.
• There is no random generation of high-scoring blocks.

The modified code is as follows:

MOVE[LEFT] = # //. {{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}} &;
MOVE[UP] = Composition[Transpose, MOVE[LEFT], Transpose];
MOVE[DOWN] = Composition[Reverse, MOVE[UP], Reverse];
MOVE[RIGHT] = Composition[Transpose, MOVE[DOWN], Transpose];
ADDBLOCK = 
  ReplacePart[#, 
    RandomChoice@Position[#, 1] -> RandomChoice[{2, 4, 6}]] &;
CALCULATESCORE = Total[If[# >= 6, 3^Log2[#/3], 0] & /@ Flatten[#]] &;
KEY = If[BLOCK != MOVE[#][BLOCK], BLOCK = ADDBLOCK[MOVE[#][BLOCK]];
    SCORE = CALCULATESCORE[BLOCK];
    Which[And @@ (BLOCK == MOVE[#][BLOCK] & /@ {LEFT, RIGHT, UP, DOWN}),
      STATE = "Game over! Score: " <> ToString[SCORE]]] &;
BLOCK = ADDBLOCK[ConstantArray[1, {4, 4}]];
STATE = "";
EventHandler[
 Dynamic[ArrayPlot[Log2@BLOCK/17, ColorFunction -> Hue, 
   ColorFunctionScaling -> False, Mesh -> All, 
   Epilog -> {MapIndexed[
      Text[If[#1 == 1, "", Style[#1/2, "Section"]], #2 - {0.5, 0.5}] &,
       Transpose@Reverse@BLOCK, {2}], 
     Text[Style[STATE, Blue, 20], {2, 2}]}]], {"LeftArrowKeyDown" :> 
   KEY[LEFT], "RightArrowKeyDown" :> KEY[RIGHT], 
  "UpArrowKeyDown" :> KEY[UP], "DownArrowKeyDown" :> KEY[DOWN]}]

I played casually and scored 3078 points. I feel that it is playable indeed.