Some time ago I asked myself: with all these great graphics and interactive capabilities of Mathematica, what kinds of 3D games can be implemented in it? And the answer which came to mind is Minecraft classic. The scene in this game is almost static, the first person view and controls can be easily implemented, the terrain textures are freely available, and the overall functionality does not seem to be complicated... There is even a related demonstration on the Demonstrations Project!

So, can Mathematica really handle Minecraft classic game functionality? Well, the answer seems to be YES :)

Here is my implementation of Minecraft classic game in Mathematica. Let’s start with some screenshots which were taken during the construction of the final scene which will be displayed an the end of this post.

Features

• Blocks are creatable and removable
• One texture per block
• Player automatically jumps to the obstacles of one block height and on the blocks which are created directly underneath. You can also try to fall down.
• Simplified selection tracking, which can miss cube corners, is implemented. Anyway it is still quite intuitive and allows to put blocks diagonally.
• Big action range: you can place and remove blocks located far away.

Controls

• W-A-S-D: move forward-left-backward-right. By default double steps are used, Shift key enables single step.
• Arrow keys: look up-down-left-right
• Mouse selects current block
• 1…9: select new block type
• B: show blocks selector
• Left mouse click: delete block
• Right mouse click or Space: create block
• R: set respawn position
• Enter: respawn
• X: Save game state
• L: Load game state

Performance tuning

Terrain construction. Simple random walk terrain generation is implemented. The following parameters can by adjusted:

prmTERRAINBLOCKSN – approximate number of terrain blocks

prmCLOUDSN – number of clouds. Each cloud consists of random number of blocks.

prmTERRAINGRAIN and prmTERRAINOFFSET control the landscape properties. On the first picture below prmTERRAINOFFSET is 8, and is 3 for the second one.

Hardware issues. On some systems the presence of a single opacity directive drastically decreases performance. In this case one can set prmDISABLETRANSPARENCY to True or/and try to use prmRENDERINGENGINE=”BSPTree”.

Conclusion

To be honest I am myself surprised how well the final code performs. On average system it easily handles thousands and even tens of thousands blocks. With the growth of this number the “gameplay” becomes too slow. It is also should be noted that what really matters is the number of faces, because hidden faces are not included in the final Graphics3D, so clustered blocks are preferable.

The result of my first construction session is

The code has been tested on Mathematica version 8.0.4 and WinXP and Win7 operation systems. Further improvements are appreciated as well as the comments about the code organisation and style. Thank you!

I would like to make some considerations about the performance of the above code (here is the link to it on Pastebin for convenience).

The speed of current implementation is both hardware and version specific. There are two main characteristics: the smoothness of motion and the speed of scene update after block creation or removal. I guess that the smoothness depends on graphics card, and the update speed on both the processor and GPU.

On my working G860 3Hz Intel processor with integrated Intel HD graphics and Win7 OS I have the following:

• The default scene with 5000 terrain blocks and 3 clouds is smooth enough for comfortable movement with disabled transparency. It speeds up a bit when no dynamic selection is displayed (when I point to the sky).

• The update speed is approximately 1-2 seconds per operation.

• The overall performance deteriorates significantly with enabled transparency. One way out is to set prmCLOUDSN=0 since it is clouds what is transparent on the default scene.

• With 20 000 terrain blocks and disabled opacity the movement is still pretty smooth, the scene update takes 2-3 seconds.

• No performance differences between versions 8 and 9 on my system.

• The scene I've constructed began with 1000 terrain blocks, no clouds (I added them manually) and no transparency. With this inital settings the scene updates momentally and is comfortable for construction. Honestly I am not sure about how transparency is handled on different systems, but on the system with an old discrete GeForce card it seemed to work faster than on integrated GPUs.

So my advices on performance improvement still are:

• Use prmTERRAINBLOCKSN and prmCLOUDSN wisely. Try to set them to zero at all.

• Try prmDISABLETRANSPARENCY=True

• Point to the sky when move

NOTE: this article was originally posted at Mathematica Stack Exchange.

This scene can be downloaded (and loaded from Mathematica) from here. Here is the code.

prmWORLDWIDTH = 200;
prmWORLDHEIGHT = 100;
prmVIEWERHEIGHT = 2.75;
prmVIEWRANGE = {0.01, 300};
prmMOVESTEP = .95;
prmACTIONRANGE = 300;
prmTRACESTEP = 0.33;
prmVIEWANGLE = 45 Degree;
prmFALLINGPAUSE = 0;
prmVERTLOOKANGLEDELTA = 4.99 Degree;
prmHORLOOKANGLEDELTA = 90 Degree/4.;
prmSKYCOLOR = RGBColor[0.58, 0.77, 0.96];
prmTEXTURESIZE = 16;
prmTERRAINBLOCKSN = 5000;
prmCLOUDSN = 3;
prmFLOORMATERIAL = matSand;
prmRENDERINGENGINE = Automatic;
prmDISABLETRANSPARENCY = False;
prmSMOOTHTERRAIN = True;
prmTERRAINGRAIN = 3;
prmTERRAINOFFSET = 3;

terrainImg = Import["http://i.imgur.com/2uAswvI.png"];
ClearAll["mat*"];
materials =
  {matGrass -> {1, 1},
   matStone -> {1, 2},
   matDirt -> {1, 3},
   matPlanks -> {1, 5},
   matPlate -> {1, 7},
   matBricks -> {1, 8},
   matCobblestone -> {2, 1},
   matBedrock -> {2, 2},
   matSand -> {2, 3},
   matGravel -> {2, 4},
   matWood -> {2, 5},
   matLeaves -> {2, 7},
   matMossStone -> {3, 5},
   matObsidian -> {3, 6},
   matGlass -> {4, 2},
   matWhiteWool -> {5, 16},
   matGrayWool -> {5, 15},
   matDarkGrayWool -> {5, 14},
   matMagentaWool -> {5, 13},
   matPinkWool -> {5, 12},
   matPurpleWool -> {5, 10},
   matBlueWool -> {5, 9},
   matLightBlueWool -> {5, 8},
   matCyanWool -> {5, 7},
   matGreenWool -> {5, 5},
   matLimeWool -> {5, 4},
   matYellowWool -> {5, 3},
   matOrangeWool -> {5, 2},
   matRedWool -> {5, 1},
   matClouds -> {1, 12},
   matSilver -> {2, 8},
   matGold -> {2, 9}
   };

dirVectors = {{0, 1, 0}, {1, 0, 0}, {0, -1, 0}, {-1, 0, 0}, {0, 
    0, -1}, {0, 0, 1}};
vtc = {{0, 0}, {1, 0}, {1, 1}, {0, 1}};
vertCoords = # - {1, 1, 1} & /@ {{0, 0, 0}, {0, 0, 1}, {1, 0, 1}, {1, 
     0, 0}, {0, 1, 0}, {0, 1, 1}, {1, 1, 1}, {1, 1, 0}};
faceCoords = {{7, 6, 5, 8}, {3, 7, 8, 4}, {2, 3, 4, 1}, {6, 2, 1, 
    5}, {5, 8, 4, 1}, {3, 2, 6, 7}};

filename = "save.mmc";


initMaterials[] := Block[{},
   nMat = Length@materials;
   Evaluate[materials[[All, 1]]] = Range[nMat];
   matAir = 0;
   With[{ts = prmTEXTURESIZE},
    textures = 
     ImageTake[terrainImg, ts (#1 - 1) + {1, ts}, 
        ts (#2 - 1) + {1, ts}] &
      @@@ (materials[[All, 2]])
    ];
   textures[[matClouds]] = 
    Image[Array[{1, 1, 1} &, {prmTEXTURESIZE, prmTEXTURESIZE}]];
   ClearAll[transparentQ];
   Do[transparentQ[mat] = 
     MemberQ[{matLeaves, matGlass, matClouds, matAir}, mat], {mat, 0, 
     nMat}];
   If[! prmDISABLETRANSPARENCY,
    textures[[matLeaves]] = 
     ImageData[
       textures[[
        matLeaves]]] /. {{1., 1., 1.} -> {0., .5, 0., 0.}, {r_, g_, 
         b_} :> {r, g, b, 1.}};
    textures[[matGlass]] = 
     ImageData[
       textures[[
        matGlass]]] /. {{1., 1., 1.} -> {5., .5, .1, 0.}, {r_, g_, 
         b_} :> {r, g, b, 1.}};
    textures[[matClouds]] = 
     Array[{1, 1, 1, .75} &, {prmTEXTURESIZE, prmTEXTURESIZE}];
    ];
   ];

initIcons[] := Block[{},
   icons = Graphics3D[{ EdgeForm@None, Texture[#],
        Polygon[# & /@ vertCoords[[#]], 
           VertexTextureCoordinates -> vtc] & /@ faceCoords},
       Lighting -> "Neutral", Boxed -> False, ImageSize -> 64, 
       Background -> Black] &
     /@ textures;
   setterbar = Column[SetterBar[
        Dynamic[
         palette[[
          curBlockType]], {(palette[[
              curBlockType]] = #) &, (updatePalette[]; 
            DialogReturn[]) &}], #] &
      /@ Partition[Thread[Range[nMat] -> icons], 6, 6, {1, 1}, {}]
     ];
   palette = {matStone, matCobblestone, matBricks, matDirt, matPlanks,
      matWood, matLeaves, matGlass, matPlate};
   curBlockType = 1;
   updatePalette[];
   ];

updatePalette[] := (paletteGfx = Image[
     GraphicsRow[icons[[palette]],
      Evaluate[Frame -> Array[# == curBlockType &, 9]],
      Evaluate[FrameStyle -> Directive[White, AbsoluteThickness@3]],
      Background -> Black
      ], ImageSize -> 500]);

updateCubes[] := (cucubes = Flatten@cubes;);

saveGame[file_] := 
  Export[file, {pos, viewDir, moveDir, strafeDir, palette, 
     curBlockType, SparseArray@blocks} // Compress, "Text"];

loadGame[file_] := Block[{p, vd, md, sd, pal, cbt, bl},
   If[! FileExistsQ[file], MessageDialog["File not found"]; Return[]];
   {p, vd, md, sd, pal, cbt, bl} = Uncompress@Import[file, "Text"];
   {pos, viewDir, moveDir, strafeDir, palette, curBlockType} = {p, vd,
      md, sd, pal, cbt};
   blocks = Normal@bl;
   dim = Dimensions@blocks;
   {prmWORLDWIDTH, prmWORLDHEIGHT} = Rest@dim;
   initFloor[];
   initCubes[]; updateCubes[]; updatePalette[]; getSelection[];
   FinishDynamic[];
   ];

saveDialog[] := CreateDialog[
   Grid@{{Dynamic["Save to file: " <> filename], 
      FileNameSetter[Dynamic[filename], "Save"]},
     {DefaultButton[saveGame[filename]; DialogReturn[]],
      CancelButton[]
      }}
   ];

loadDialog[] := CreateDialog[
   Grid@{{Dynamic["Load from file: " <> filename], 
      FileNameSetter[Dynamic[filename], "Open", {"mmc" -> {"*"}}]},
     {DefaultButton[loadGame[filename]; DialogReturn[]],
      CancelButton[]
      }}
   ];

showBlockChooser[] := CreateDialog[setterbar, {},
   WindowSize -> 500,
   Background -> Black,
   Modal -> True,
   WindowFrame -> "Frameless",
   TextAlignment -> Center
   ];

initBlocks[] := (
   dim = {prmWORLDWIDTH, prmWORLDWIDTH, prmWORLDHEIGHT};
   blocks = Array[0 &, dim];
   );

initCamera[] := Block[{},
   pos = {1.5, 1.5, prmVIEWERHEIGHT};
   height = Ceiling@prmVIEWERHEIGHT;
   moveDir = {1, 1, 0} // Normalize;
   viewDir = moveDir;
   strafeDir = {1, -1, 0} // Normalize;
   respawnPos = Null;
   currentBlockPos = newBlockPos = Null;
   selection = {};
   viewAngle = 0;
   ];

initFloor[] := (floor = With[{w = prmWORLDWIDTH},
     {EdgeForm[None],
      Texture[textures[[prmFLOORMATERIAL]]],
      Polygon[{{0, 0, 0}, {0, w, 0}, {w, w, 0}, {w, 0, 0}},
       VertexTextureCoordinates -> {{0, 0}, {w, 0}, {w, w}, {0, w}}]}
     ]);

initCubes[] := Block[{g, type, pointers, faces},
   cubes = {Texture@#} & /@ textures;
   cubePointers = Developer`ToPackedArray[{{0, 0, 0}}] & /@ textures;
   g = ParallelMap[{#, createCube[#]} &,
     Position[blocks, b_ /; b > 0]];
   Scan[({pointers, faces} = Transpose@#;
      type = blockAt@First@pointers;
      cubes[[type]] = cubes[[type]]~Join~faces;
      cubePointers[[type]] = cubePointers[[type]]~Join~pointers;
      ) &,
    GatherBy[g, blockAt@First@# &]
    ];
   ];

processFalling[] := Block[{i, j, k}, While[
    ({i, j, k} = blockPos[pos])[[3]] > height && 
     blocks[[i, j, k - height]] == 0,
    pos -= {0, 0, 1}; FinishDynamic[]; Pause[prmFALLINGPAUSE]
    ]];


lookHor[da_] := ({moveDir, strafeDir, viewDir} = 
    RotationTransform[da, {0., 0., 1.}] /@ {moveDir, strafeDir, 
      viewDir});
lookVert[da_] :=
  If[Abs[viewAngle + da] <= Pi/2,
   viewAngle += da;
   viewDir = RotationTransform[da, strafeDir]@viewDir
   ];

move[dv_, n_Integer] := Do[move@dv, {n}];
move[dv_] := Block[{newpos, i, j, k, space},
   newpos = pos + dv;
   If[! inRange@newpos, Return[]];
   {i, j, k} = blockPos@newpos;
   If[k + 1 > prmWORLDHEIGHT, Return[]];
   space = blocks[[i, j, (k - height + 1) ;; k + 1]];
   Which[
    And @@ Thread[Most@space == 0], pos = newpos,
    First@space != 0 && (And @@ Thread[Rest@space == 0]), 
    pos = newpos + {0, 0, 1}
    ];
   processFalling[];
   ];


processKeyboard[] := (
  Switch[CurrentValue["EventKey"],
   "W", move[prmMOVESTEP  moveDir],
   "S", move[-prmMOVESTEP moveDir],
   "A", move[-prmMOVESTEP strafeDir],
   "D", move[prmMOVESTEP strafeDir],
   "w", move[prmMOVESTEP  moveDir, 2],
   "s", move[-prmMOVESTEP  moveDir, 2],
   "a", move[-prmMOVESTEP  strafeDir, 2],
   "d", move[prmMOVESTEP  strafeDir, 2],
   "q", pos += {0, 0, 1},
   "b", showBlockChooser[],
   "r", (respawnPos = pos),
   "x", saveDialog[],
   "l", loadDialog[],
   " ", addCurrentBlock[],
   "1", curBlockType = 1; updatePalette[],
   "2", curBlockType = 2; updatePalette[],
   "3", curBlockType = 3; updatePalette[],
   "4", curBlockType = 4; updatePalette[],
   "5", curBlockType = 5; updatePalette[],
   "6", curBlockType = 6; updatePalette[],
   "7", curBlockType = 7; updatePalette[],
   "8", curBlockType = 8; updatePalette[],
   "9", curBlockType = 9; updatePalette[]
   ];
  getSelection[];
  )

actions = {
   {"MouseDown", 1} :> deleteCurrentBlock[],
   {"MouseUp", 2} :> (addCurrentBlock[]; getSelection[]),
   "MouseMoved" :> getSelection[],
   "LeftArrowKeyDown" :> lookHor[prmHORLOOKANGLEDELTA],
   "RightArrowKeyDown" :> lookHor[-prmHORLOOKANGLEDELTA],
   "UpArrowKeyDown" :> lookVert[prmVERTLOOKANGLEDELTA],
   "DownArrowKeyDown" :> lookVert[-prmVERTLOOKANGLEDELTA],
   "ReturnKeyDown" :> If[respawnPos =!= Null, move[respawnPos - pos]],
   "KeyDown" :> processKeyboard[],
   PassEventsDown -> False
   };

inRange = And @@ Thread[{0, 0, 0} < # <= dim] &;
blockAt = blocks[[Sequence @@ #]] &;
setBlock = (blocks[[Sequence @@ #1]] = #2) &;
setMouse[expr_] := MouseAppearance[expr, "Arrow"];
blocksCount[] := Count[blocks, b_ /; b != 0, {3}];
facesCount[] := Count[cubes, Polygon[__], {3}];
blockPos = Ceiling;


neighborList[p_] := Block[{cf},
   cf = If[transparentQ@blockAt@p,
     (blockAt[#] == matAir) &,
     (transparentQ@blockAt[#] &)
     ];
   Quiet[Flatten@
     Position[p + # & /@ dirVectors, _?(inRange[#] && cf[#] &), {1}, 
      Heads -> False]]
   ];

createCube[coords_] :=
  Polygon[coords + # & /@ vertCoords[[#]], 
     VertexTextureCoordinates -> vtc] & /@ 
   faceCoords[[neighborList@coords]];

setCube[coords_, type_] := (
  AppendTo[cubes[[type]], createCube[coords]];
  AppendTo[cubePointers[[type]], coords];
  )

addBlock[bp : {_Integer, _Integer, _Integer}?inRange] := (
   setBlock[bp, palette[[curBlockType]]];
   setCube[bp, palette[[curBlockType]]];
   updateNeighbors@bp;
   );

neighborCoords[p_] := 
  Quiet[Cases[
    p + # & /@ dirVectors, _?(inRange[#] && blockAt[#] != matAir &), 
    1]];

updateNeighbors[p_] := Block[{np, locs},
   np = neighborCoords@p;
   locs = 
    ParallelMap[Position[cubePointers, #, {2}, Heads -> False] &, np];
   (cubes[[Sequence @@ (First@#1)]] = createCube@#2) & @@@ 
    Transpose@{locs, np};
   ];

deleteBlock[bp : {_Integer, _Integer, _Integer}?inRange] := 
  Block[{loc},
   loc = Position[cubePointers, bp, {2}, Heads -> False];
   setBlock[bp, 0];
   cubePointers = Delete[cubePointers, loc[[1]]];
   cubes = Delete[cubes, loc[[1]]];
   updateNeighbors@bp;
   ];

addCurrentBlock[] :=
  If[newBlockPos != blockPos@pos,
   getSelection[];
   addBlock@newBlockPos;
   move@{0, 0, 0};
   getSelection[];
   updateCubes[];
   ];

deleteCurrentBlock[] := (
   getSelection[];
   deleteBlock@currentBlockPos;
   getSelection[];
   processFalling[];
   updateCubes[];
   );

getSelection[] := Block[{flag, found, chain, mp},
   flag = False;
   mp = MousePosition["Graphics3DBoxIntercepts", Null];
   currentBlockPos = newBlockPos = Null;
   selection = {};
   If[mp === Null, Return[]];
   v = Normalize[Subtract @@ mp];
   If[v.viewDir < 0, v = -v];
   found = (flag = (Last@# < 0 || blockAt[blockPos@#] != 0)) &;
   chain = NestWhileList[
     # + prmTRACESTEP v &,
     pos,
     (And @@ Thread[{0, 0, -1} < # < dim]) && (! found@#) &,
     1, Ceiling[prmACTIONRANGE/prmTRACESTEP]];
   If[flag,
    currentBlockPos = blockPos@chain[[-1]];
    selection = {EdgeForm@{Black, Thick},
      FaceForm[None],
      Cuboid[currentBlockPos - 1, currentBlockPos]
      };
    If[Length@chain > 1, newBlockPos = blockPos@chain[[-2]]];
    ];
   ];

(*World generation*)

randomWalkPattern[nb_, m_, d_] := 
  Module[{n = prmWORLDWIDTH, q, i0, j0, i1, j1, field, applyAt, 
    offset, ok, p, next},
   field = Array[0 &, {n, n}];
   applyAt = 
    Function[{i, j}, field[[i - m ;; i + m, j - m ;; j + m]] += 1];
   offset = RandomInteger[d {-1, 1}, {2}] &;
   ok = (m < #1 <= n - m) && (m < #2 <= n - m ) &;
   next = (While[! ok @@ (q = # + offset[]), q]; q) &;
   p = Floor[{n, n}/2];
   Do[applyAt @@ p; p = next@p, {Round[nb/(2 m + 1)^2]}];
   If[prmSMOOTHTERRAIN,
    ListConvolve[BoxMatrix[2]/25, field] // Round,
    field]
   ];

createTerrain[bc_] := Block[{field},
   field = randomWalkPattern[bc, prmTERRAINGRAIN, prmTERRAINOFFSET];
   With[{h = Min[field[[##]], prmWORLDHEIGHT]},
      blocks[[#1, #2, 1 ;; h]] = 
       RandomChoice[{matGravel, matStone}, h];
      blocks[[#1, #2, 1]] = RandomChoice@{matBedrock, matDirt};
      If[1 < h < RandomInteger@{4, 9},
       blocks[[#1, #2, h - 1 ;; h]] = matDirt;
       If[RandomChoice@{True, False}, blocks[[#1, #2, h]] = matGrass];
       ];
      ] & @@@ Position[field, b_ /; b > 0, {2}];
   ];

createClouds[nClouds_] := 
  Block[{cloud, ww = prmWORLDWIDTH, wh = prmWORLDHEIGHT, i, j, h},
   Do[
     cloud = randomWalkPattern[RandomInteger@{200, 1000}, 1, 2];
     {i, j} = RandomInteger[{-ww, ww}/2, 2];
     h = RandomInteger@{wh/2, wh};
     Quiet[blocks[[#1 + i, #2 + j, h]] = matClouds] & @@@ 
      Position[cloud, b_ /; b != 0, {2}],
     {nClouds}
     ];
   ];


initMaterials[];
initIcons[];
initBlocks[];
createTerrain[prmTERRAINBLOCKSN];
createClouds[prmCLOUDSN];
initFloor[];
initCubes[];
initCamera[];

updateCubes[];

scene = Graphics3D[{Dynamic@floor, EdgeForm@None, Dynamic@cucubes, 
    Dynamic@selection},
   ViewVector -> Dynamic@{pos, pos + viewDir},
   ViewRange -> prmVIEWRANGE,
   PlotRange -> All,
   Lighting -> "Neutral",
   Boxed -> False,
   BoxRatios -> Automatic,
   ImageSize -> 
    Dynamic@AbsoluteCurrentValue[EvaluationNotebook[], WindowSize],
   ViewAngle -> prmVIEWANGLE,
   Background -> prmSKYCOLOR,
   PlotRangePadding -> 0,
   Epilog -> {crosshair, Inset[Dynamic@paletteGfx, Scaled@{.5, .05}]}
   ];

crosshair = {White, AbsoluteThickness@2,
   Line[{Scaled@{.49, .5}, Scaled@{.51, .5}}],
   Line[{Scaled@{.5, .49}, Scaled@{.5, .51}}]
   };

CreateDocument[
  EventHandler[
   setMouse@Style[scene, Selectable -> False, Editable -> False],
   actions
   ],
  CellMargins -> 0,
  ShowCellBracket -> False,
  ShowCellLabel -> False,
  "TrackCellChangeTimes" -> False,
  WindowElements -> {},
  WindowFrame -> "Normal",
  WindowSize -> Full,
  "BlinkingCellInsertionPoint" -> False,
  "CellInsertionPointCell" -> {},
  WindowMargins -> Automatic,
  WindowTitle -> "Mathematicraft",
  Background -> Black,
  Editable -> False,
  NotebookEventActions -> actions,
  TextAlignment -> Center,
  Deployed -> True,
  RenderingOptions -> {"Graphics3DRenderingEngine" -> 
     prmRENDERINGENGINE}
  ];

blocksCount[]
facesCount[]