SetOptions[InputNotebook[],NotebookEventActions->{ "LeftArrowKeyDown":>(stat=Coalesce[stat];AddNew[]), "RightArrowKeyDown":>(stat=Reverse/@Coalesce[Reverse/@stat];AddNew[]), "UpArrowKeyDown":>(stat=Coalesce[stat\[Transpose]]\[Transpose];AddNew[]), "DownArrowKeyDown":>(stat=(Reverse/@(Coalesce[Reverse/@(stat\[Transpose])]))\[Transpose];AddNew[]) } ]; n=4; bgcolor=GrayLevel[0.84]; colorfunc=Blend[{{0,Gray},{1/2,Red},{1,Blend[{Yellow,Orange}]}},#]&; ClearAll[AddNew,PrintStat,Coalesce,SubCoalesce,AddRandomNumber] AddNew[]:=(stat=AddRandomNumber[stat]) PrintStat[stat_]:=Module[{gr1,gr2,gr3,dr=0.2,cols,nstat=stat,positions}, gr1={bgcolor,Rectangle[-dr{1,1},n+dr{1,1},RoundingRadius->dr]}; cols=Map[If[#==0,0,Log2[#]]&,nstat,{2}]; cols=Map[If[#==0,Lighter@bgcolor,colorfunc[#/Max[cols]]]&,cols,{2}]; positions=Table[{i,n-j+1},{j,n},{i,n}]; gr2=MapThread[{#2,Rectangle[#3-{1,1}(1-dr/3),#3-{1,1}dr/3,RoundingRadius->dr/2]}&,{stat,cols,positions},2]; gr3=MapThread[If[#1>0,Style[Text[#1,#2-0.5{1,1}],20,White],{}]&,{stat,positions},2]; Graphics[{gr1,gr2,gr3},PlotRange->{{-0.5,n+0.5},{-0.5,n+0.5}},ImageSize->500] ] Coalesce[stat_]:=SubCoalesce/@stat SubCoalesce[statlist_]:=Module[{st=statlist,n=Length[statlist],pairs}, st=Split[DeleteCases[st,0]]; st=Partition[#,2,2,1,{}]&/@st; st=Map[If[Length[#]==2,Total[#],#]&,st,{2}]; Join[Flatten[st],ConstantArray[0,n-Length[Flatten[st]]]] ] AddRandomNumber[stat_,n_:2]:=With[{pos=Position[stat,0,{2}]},If[Length[pos]>0,ReplacePart[stat,RandomChoice[pos]->n],stat]] stat=Nest[AddRandomNumber[#,RandomChoice[{2,4}]]&,ConstantArray[0,{n,n}],4]; Dynamic[PrintStat@stat]