(*
Mathematica Minecraft classic implementation
see http://mathematica.stackexchange.com/q/19669 for details
*)

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]]];
    ];
   ];

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[]