Video Games in the Wolfram Language™

Kevin Daily
Wolfram Research

Let’s Start with Something Fun: Circle Pong

The following code was edited from Philip Maymin’s submission (and winning entry) for the 2016 One-Liner Competition.

The original Pong was released in 1972:

playCirclePong[speed_:1]:=DynamicModule[{locatorPosition={0,1},ballPosition={0,0},score=0,ballDirection={0,1}},
Graphics[{
Circle[],
Dynamic@Inset[score,
ballPosition+=If[Norm[locatorPosition-ballPosition]<0.1,
score++;
ballDirection={Cos[score],Sin[score]}-ballPosition,
If[Norm[ballPosition]<2,ballDirection,0]
]*speed/900.],
Locator@ Dynamic[locatorPosition,(locatorPosition=#/Norm[#])&]
},
PlotRange->1.1 {{-1,1},{-1,1}}]
]

playCirclePong[]

Point-and-Click Adventures

For reference (1986): Space Quest:

DynamicModule[{pt={4.5,0.1},vec,frames={,,,,,,,,},i=1},
ClickPane[
Framed[Graphics[Dynamic@Inset[frames[[i]],pt,Scaled[{0,0}],0.186],PlotRange->{{0,5},{0,2.52}},ImagePadding->None,PlotRangePadding->None,Prolog->Inset[,{0,0},Scaled[{0,0}],5.06],ImageSize->Large],FrameMargins->None],
(vec=(#-pt)/Norm[#-pt]/30;
Do[pt+=vec;i=1+Mod[i,9];FinishDynamic[],{i,Norm[#-pt] 30}])&
]
]

Tetris (1984)

The following Tetris clone is from Boris Faleichik and Nikita Seredinski: http://community.wolfram.com/groups/-/m/t/879149.

The code was slightly modified to add background music.

Source Code

(* ::Package::*)
BeginPackage["Tetris`"] ;

Tetris::usage="Tetris[] starts game";

Begin["Private`"];

tetrisMusic=;
{w,h}={14,26};bg={0,0,0};(*background color*)
br={.3,.3,.3};(*border color*)
speed0=.6;(*initial speed*)
fallspeed=0.001;
acc=0.8;(*speed acceleration factor*)
sounds=False;
lpl=2;(*lines per level*)
sndbrick=Play[Sin[1000 t]+Cos[1100 t],{t,0,.1}];
gomsg="GAME OVER";
bcaption=" New game ";

figs={(*figure:{coords,color}*)
{{{0,-1},{0,0},{0,1},{1,-1}},{0.1,0.1,1.0}}(*J*),{{{0,-1},{0,0},{0,1},{1,1}},{1.0,0.5,0.0}}(*L*),{{{1,0},{0,0},{1,-1},{0,1}},{1.0,0.0,0.0}}(*Z*),{{{1,0},{0,0},{0,-1},{1,1}},{0.1,1.0,0.1}}(*S*),{{{0,1},{0,0},{0,2},{0,-1}},{0.1,0.9,1.0}}(*I*),{{{0,0},{1,0},{1,1},{0,1}},{1.0,1.0,0.1}}(*O*),{{{0,-1},{0,0},{0,1},{1,0}},{0.9,0.1,1.0}}(*T*)};

init[]:=(
oldspeed=0;
speed=speed0;
lines=score=level=0;
glass=Table[
If[1<j<w&&i>1,bg,br]
,{i,h},{j,w}
];
nextglass=Table[bg,{4},{6}];
fig7=RandomSample@figs;
nfig=First@fig7;
fig7=Rest@fig7;
newmask[];
playing=False;
benabled=True;
msg="";
RemoveScheduledTask/@ScheduledTasks[];
);

newmask[]:=(mask=Map[#==bg&,glass,{2}]);

newfig[]:=(
put[nextglass,nfig[[1]],{2,3},bg];
{fig,fc}=nfig;
nfig=First@fig7;
fig7=Rest@fig7;
If[fig7==={},fig7=RandomSample@figs];
put[nextglass,nfig[[1]],{2,3},nfig[[2]]];
{y,x}={h-3,Floor[w/2]};
If[check[fig,{y,x}]
,put[glass,fig,{y,x},fc]
,stop[]
;playing=False
;benabled=True
;msg=gomsg
;EmitSound[Sound@SoundNote[SoundVolume->0]]
;Return[]
];
If[oldspeed≠0
,stop[]
;speed=oldspeed
;oldspeed=0
;start[]
];
);

rotate[f_]:=If[f[[1]]=={0,0},f,{{0,-1},{1,0}}.#&/@f];

SetAttributes[do,HoldAll];
do[act_]:=If[playing,act];

stop[]:=RemoveScheduledTask[t];
start[]:=StartScheduledTask[t=CreateScheduledTask[move[],speed]];

move[]:=(
If[check[fig,{y-1,x}]
,put[glass,fig,{y,x},bg]
;put[glass,fig,{--y,x},fc]
,es@sndbrick
;newmask[];del[];newfig[]
]
);

turn[]:=Block[{newf},
newf=rotate@fig;
If[check[newf,{y,x}]
,put[glass,fig,{y,x},bg]
;fig=newf
;put[glass,fig,{y,x},fc]]
];

shift[dx_]:=If[check[fig,{y,x+dx}]
,put[glass,fig,{y,x},bg]
;x+=dx;
;put[glass,fig,{y,x},fc]
];

SetAttributes[es,HoldFirst];
es[s_]:=If[sounds,EmitSound@s];

price[n_]:=Switch[n,1,40,2,100,3,300,4,1200];

del[]:=Module[{sel,g,ln},
sel=Not[Or@@#]&/@mask;
sel[[1]]=False;
g=Pick[glass,Not/@sel];
If[(ln=h-Length@g)>0
,glass=g~Join~Table[If[1<i<w,bg,br],{ln},{i,w}]
;es@Play[UnitStep@Sin[2000 t] Sin[5000 t t],{t,0,.2 (ln)}]
;lines+=ln
;score+=price[ln]*(level+1)
;cl=Quotient[lines,lpl];
;If[cl>level,level=cl;stop[];speed*=acc;
oldspeed*=acc;start[]]
;newmask[]
];
];

SetAttributes[#,HoldFirst]&/@{set,put};

set[g_,p_,c_]:=(g[[Sequence@@p]]=c);

put[g_,f_,p_,c_]:=set[g,#,c]&/@(#+p&/@f);

get[p_]:=mask[[Sequence@@p]];

check[f_,p_]:=And@@(get/@(#+p&/@f));

drop[]:=If[speed≠fallspeed
,stop[];
playing=False;
;oldspeed=speed
;speed=fallspeed
;start[];playing=True;
];

menu=Button[bcaption
,init[]
;newfig[]
;EmitSound[tetrisMusic]
;playing=True
;start[]
;benabled=False;
,Enabled->Dynamic@benabled
];

Tetris[]:=DynamicModule[{},
init[];
EventHandler[
Graphics[{
Raster@Dynamic@glass[[;;-4]]
,Raster[Dynamic@nextglass,{{w,h-7},{w+6,h-3}}]
,Text[Style["Score",24,White,Bold],{w,17},{-1,0}]
,Text[Style[Dynamic@score,24,White,Bold],{w+6,17},{1,0}]
,Text[Style["Lines",24,Green,Bold],{w,14},{-1,0}]
,Text[Style[Dynamic@lines,24,Green,Bold],{w+6,14},{1,0}]
,Text[Style["Level",24,Cyan,Bold],{w,11},{-1,0}]
,Text[Style[Dynamic@level,24,Cyan,Bold],{w+6,11},{1,0}]
,Text[Style[Dynamic@msg,24,White,Bold],{w+3,7},{0,0}]
,Inset[menu,{w+3,2}]
}
,PlotRange->{{0,w+7},{0,h-2}}
,Background->RGBColor@br
,ImageSize->600]
,{"RightArrowKeyDown":>do@shift@1
,"LeftArrowKeyDown":>do@shift@-1
,"UpArrowKeyDown":>do@turn[]
,"DownArrowKeyDown":>do@drop[]
}
]
];

End[];

EndPackage[];

Play

Tetris[]

Classic Minesweeper (1989)

All credit goes to Benjamin Goodman. This code is taken from his Wolfram Community™ post: http://community.wolfram.com/groups/-/m/t/847797.

The code has been edited for enhanced readability.

Code in Steps

Step 1: Generate starting grid

(* generates random starting grid of given side length and mine probability *)
(* grid[mineProb,gridLength] *)
grid=RandomChoice[{#1,1-#1}-> {"m",0},{#2,#2}]&;

(* probability that location is a mine *)
mineProb=0.1;

(* side length of grid *)
gridLength=10;

test=grid[mineProb,gridLength]

Grid[test]

Step 2: Get safe and mine locations

safe=(*array positions of safe tiles*)Position[test,0]
mines=(*array positions of mine tiles*)Position[test,"m"]

Step 3: Find nearest neighbors (NN) of each safe location

(* NNs of given location *)
nn=(*nearest neighbors *)Select[0<#[[1]]≤ gridLength&]@Select[0<#[[2]]≤ gridLength&]@{{#1-1,#2-1},{#1-1,#2},{#1-1,#2+1},{#1,#2-1},{#1,#2},{#1,#2+1},{#1+1,#2-1},{#1+1,#2},{#1+1,#2+1}}&;

(* number of NNs that are mines for each safe location *)
mineCount=Table[Length[Flatten[Intersection[nn[First@safe[[#]],Last@safe[[#]]],mines]]]/2&[i],{i,1,Length[safe]}]

Step 4: insert NN mine counts

(* these are the "tips" that tell the user the number of adjacent mines to the uncovered tile *)
new=(*insert nn mine count*)ReplacePart[test,Table[safe[[i]]-> mineCount[[i]],{i,1,Length[safe]}]]

Grid[new]

Step 5: Generate user interface

(* this is what the user will see ("U" for Uncovered) *)
show=ConstantArray["U",Dimensions[new]];

Grid[show]

Step 6: Generate list of tip value and plot location

Inset uses image coordinates, while the grid uses array coordinates—they are not the same:

(* plot location of tip corresponding to array location of associated array entry *)
index=Flatten[Table[{j,i},{i,gridLength,1,-1},{j,1,gridLength,1}],1]

(* Use to label array plot with tile tips *)  
tips=Table[Inset[(Style[#,Black,12,"Title"]&/@ToString/@(Flatten[new]/.{0->""}))[[i]],index[[i]]-0.5],{i,1,gridLength^2}]

Step 7: Generate color scheme

colRules=Join[
Normal[AssociationThread[Range[8]->(Rest[(Hue[1,#,1]&/@Rescale[Range[9]])])]],
{"m"->Hue[1,1,0],"U"->GrayLevel[0.8],"F"->RGBColor[0.2,0.5,0.7]}
]

Step 8: Plot game grid

(*we need to be selective about how the tips are inserted *)
ArrayPlot[
show,
Frame->False,Mesh->All,ColorRules->colRules,ImageSize->450,Epilog->{tips}]

(* what the player sees at start of game *)
ArrayPlot[
show,
Frame->False,Mesh->All,ColorRules->colRules,ImageSize->450,Epilog->{(*plot tips on uncovered tiles only*)Extract[tips,Most@Rest@Position[Flatten[show],Except["U"|"F"]]]}]

(* what the player sees in lose condition *)
ArrayPlot[
new,
Frame->False,Mesh->All,ColorRules->colRules,ImageSize->450,Epilog->{(*plot tips on uncovered tiles*)tips}]

(* incorporate both using conditionals *)
lose=False;
ArrayPlot[
Which[
lose==False,show,
True,new],
Frame->False,Mesh->All,ColorRules->colRules,ImageSize->450,Epilog->{(*plot tips on uncovered tiles*)If[lose==True,tips,Extract[tips,Most@Rest@Position[Flatten[show],Except["U"|"F"]]]]}]

Step 9: Add interactivity using `ClickPane`

(* converts rounded ClickPane` output coordinates to array location *)
clickID:={gridLength-#[[2]],1+#[[1]]}&;

Dynamic@ClickPane[
(* PLOT INTERFACE FROM STEP 8 *)
ArrayPlot[
Which[
lose==False,show,
True,new],
Frame->False,Mesh->All,ColorRules->colRules,ImageSize->450,Epilog->{(*plot tips on uncovered tiles*)If[lose==True,tips,Extract[tips,Most@Rest@Position[Flatten[show],Except["U"|"F"]]]]}],

(* MOUSE INTERACTIVE CONTROLS *)

(* takes click location and rounds to nearest square *)
(pt=IntegerPart[#];

(* DEFAULT - CLICK TO UNCOVER TILE *)
If[CurrentValue["ShiftKey"]==False,

(* 'uncover' tile by replacing the `show` array with its corresponding value according to the array computed in step 3 *)
show=ReplacePart[show,clickID[pt]->Extract[new,clickID[pt]]],

(* OTHERWISE, IF SHIFT KEY IS PRESSED: *)
(* if Shift Key is pressed *)
Which[
(* toggle flags for covered tiles *) 
Extract[show,clickID[pt]]=="U",show=ReplacePart[show,clickID[pt]->"F"],
Extract[show,clickID[pt]]=="F",show=ReplacePart[show,clickID[pt]->"U"]
]
];)&]

This is the most basic level of interactivity. Note that there is no enforcement of rules and no automation (i.e. chain uncovering of blank tiles, automatic NN uncovering for selected tiles; user needs to click a lot to play—quickly becomes tedious!).

Step 10: Add win/lose conditions

(*win condition *)
(* if all safe tiles have been uncovered and the player has not lost *)
win:=Position[show,"U"|"F"]==mines&&lose==False;

(* lose conditions *)
(* if the player reveals a mine *)
lose:=ContainsAny[Position[show,"m"],mines];

Step 11: Add automation

(* 1 *)
(* associate NNs of clicked (blank) tile with their tips. Since the uncovered tile is blank, these will always be free of mines *)stepNew=AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[new,nn[clickID[pt][[1]],clickID[pt][[2]]]]]

(* hence, these may be uncovered immediately *)
show=ReplacePart[show,Normal[stepNew]];

(* carry results over to next step *)
stepOld=stepNew;

(* 2 *)
(* for the NNs from (1), for those that are also blank, get their NNs too *)
stepNew=AssociationThread[Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]-> Extract[new,Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]]]

(* uncover tiles *)
show=ReplacePart[show,Normal[stepNew]];

(* carry results over to next step *)
stepOld=stepNew;

(* we can now loop this process (3) *)

Do[
(* 2*)
stepNew=AssociationThread[Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]-> Extract[new,Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]]];
show=ReplacePart[show,Normal[stepNew]];
stepOld=stepNew,
100]

Using Do 100 times is lazy; I could not find a satisfactory end condition and I was keen to move on with the project.

The entire procedure can be wrapped up as a delayed evaluation (4), ready to be called in the case of a user clicking on an empty tile:

(* to be called if player uncovers an empty tile (without tip) *)
(* 4 *)
chainUncover:=(
(*if click ID = 0 *)
(* 1 *)
stepNew=AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[new,nn[clickID[pt][[1]],clickID[pt][[2]]]]];
show=ReplacePart[show,Normal[stepNew]];
stepOld=stepNew;
(* NNs of blank tiles from step 1 *)
(* 3 *)
Do[
(* 2*)
stepNew=AssociationThread[Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]-> Extract[new,Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]]];
show=ReplacePart[show,Normal[stepNew]];
stepOld=stepNew,
100]
)

Step 12: Putting it all together

ClickPane user interface:

(* We want to wrap everything up in `Manipulate` *)

(* this is the game *)
ClickPane[
(* display *)
ArrayPlot[
Which[
lose==False,show,
True,new
],
Frame->False,
Mesh->All,
ColorRules->colRules,
ImageSize->450,
Epilog->{
(*plot tips on uncovered tiles*)
If[lose==True,tips,Extract[tips,Most@Rest@Position[Flatten[show],Except["U"|"F"]]]]
}
],

(* click actions *)
(pt=IntegerPart[#];
If[CurrentValue["ShiftKey"]==False,
(* uncover tile on regular mouse click *)
(* if tile is blank *)
If[Extract[new,clickID[pt]]==0,
(* uncover tiles plus NNs.. *)
chainUncover,
(* else, uncover tile *)
show=ReplacePart[show,clickID[pt]->Extract[new,clickID[pt]]]
],

(* if Shift Key is pressed *)
Which[
(* reveal NNs for uncovered tiles *)
Extract[show,clickID[pt]]=!="U"=!="F",show=ReplacePart[show,Normal[
AssociationThread[Keys[Select[AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[show,nn[clickID[pt][[1]],clickID[pt][[2]]]]],#1=="U"&]]->
Extract[new,#]&[Keys[Select[AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[show,nn[clickID[pt][[1]],clickID[pt][[2]]]]],#1=="U"&]]]]]],
(* toggle flags for covered tiles *) 
Extract[show,clickID[pt]]=="U",show=ReplacePart[show,clickID[pt]->"F"],
Extract[show,clickID[pt]]=="F",show=ReplacePart[show,clickID[pt]->"U"]
]
];
)&
]

Game settings user interface:

(* these are the Manipulate controllers *)
Row[{
Column[{
(* sets length of grid *)
Control[{{gridLength,10,"Grid Size"},{10->"Small",20->"Medium",30->"Large"(*,40->"X Large"*)}}],

(* sets probability for mine *)
Control[{{mineProb,0.1,"Mine Density"},{0.05->"Beginner",0.1->"Easy",0.15->"Medium",0.25->"Hard",0.3->"Expert",0.4->"Pro"}}],

(* Reinitializes game (newGame) under current settings *)
 Button[Dynamic@Which[lose==True,"You lose - Play Again?",win==True,"You Win - Play Again?",True, "Restart"],newGame]
}],

(* reads and displays number of mines and flags *)
Panel[
Column[{
Row[{TextCell["Mines: "],Dynamic@Length[mines]}],
Row[{TextCell["Flags: "],Dynamic@Count[show,"F",2]}]
}]
]},Spacer[20]]

`New game` function:

(* everything needed to create a new game goes here *)
newGame:=(
label="Restart";
test=grid[mineProb,gridLength];

(*array positions of safe tiles*)
safe=Position[test,0];

(*array positions of mine tiles*)
mines=Position[test,"m"];

(*number of NNs that are mines*)
mineCount=Table[Length[Flatten[Intersection[nn[First@safe[[#]],Last@safe[[#]]],mines]]]/2&[i],{i,1,Length[safe]}];
new=Replace[test,1->"m",2];

(*insert nn mine count*)
new=ReplacePart[test,Table[safe[[i]]-> mineCount[[i]],{i,1,Length[safe]}]];
show=ConstantArray["U",Dimensions[new]];
index=Flatten[Table[{j,i},{i,gridLength,1,-1},{j,1,gridLength,1}],1];
tips=Table[Inset[(Style[#,Black,12,"Title"]&/@ToString/@(Flatten[new]/.{0->""}))[[i]],index[[i]]-0.5],{i,1,gridLength^2}];
)

Preceding functions initialize before Manipulate runs:

(* everything needed to run the program goes here *)
(* this will be automatically evaluated by Manipulate *) 
Initialization:>(

(* FUNCTIONS - Once set, they may be called at any time *)
clickID:={gridLength-#[[2]],1+#[[1]]}&;
chainUncover:=(
(*if click ID = 0 *)
stepNew=AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[new,nn[clickID[pt][[1]],clickID[pt][[2]]]]];
show=ReplacePart[show,Normal[stepNew]];
stepOld=stepNew;
(* NNs of blank tiles from step 1 *)
Do[
stepNew=AssociationThread[Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]-> Extract[new,Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]]];
show=ReplacePart[show,Normal[stepNew]];
stepOld=stepNew,
100]
);

(*nearest neighbors of nth entry of safe tiles - long version*)
nn=Select[#[[2]]≤ gridLength&]@Select[#[[1]]≤ gridLength&]@DeleteCases[#,{0,Integer_}]&@DeleteCases[#,{Integer_,0}]&@{{#1-1,#2-1},{#1-1,#2},{#1-1,#2+1},{#1,#2-1},{#1,#2},{#1,#2+1},{#1+1,#2-1},{#1+1,#2},{#1+1,#2+1}}&;

(*generate random starting grid*)
grid=RandomChoice[{#1,1-#1}-> {"m",0},{#2,#2}]&;

colRules=Join[
Normal[AssociationThread[Range[8]->(Rest[(Hue[1,#,1]&/@Rescale[Range[9]])])]],
{"m"->Hue[1,1,0],"U"->GrayLevel[0.8],"F"->RGBColor[0.2,0.5,0.7]}
];

(*win condition *)
win:=Position[show,"U"|"F"]==mines&&lose==False;

(* lose conditions *)
lose:=ContainsAny[Position[show,"m"],mines];

(* INITILIZE - Everything that must be evaluated before the program is used for the first time *)

(* default variables *)
mineProb=0.1;gridLength=10;pt={0,0};

(* our newGame as defined earlier *)
newGame:=(
label="Restart";
test=grid[mineProb,gridLength];

(*array positions of safe tiles*)
safe=Position[test,0];

(*array positions of mine tiles*)
mines=Position[test,"m"];

(*number of NNs that are mines*)
mineCount=Table[Length[Flatten[Intersection[nn[First@safe[[#]],Last@safe[[#]]],mines]]]/2&[i],{i,1,Length[safe]}];
new=Replace[test,1->"m",2];

(*insert nn mine count*)
new=ReplacePart[test,Table[safe[[i]]-> mineCount[[i]],{i,1,Length[safe]}]];
show=ConstantArray["U",Dimensions[new]];
index=Flatten[Table[{j,i},{i,gridLength,1,-1},{j,1,gridLength,1}],1];
tips=Table[Inset[(Style[#,Black,12,"Title"]&/@ToString/@(Flatten[new]/.{0->""}))[[i]],index[[i]]-0.5],{i,1,gridLength^2}];
);

(* then have it evaluate it to make a new (and first) game *)
newGame;
)

The Complete Code

minesweeperCDF=Manipulate[
ClickPane[
ArrayPlot[
Which[
lose==False,show,
True,new],
Frame->False,Mesh->All,ColorRules->colRules,ImageSize->450,Epilog->{(*plot tips on uncovered tiles*)If[lose==True,tips,Extract[tips,Most@Rest@Position[Flatten[show],Except["U"|"F"]]]]}],
(pt=IntegerPart[#];
If[CurrentValue["ShiftKey"]==False,
(* uncover tile *)
(* if tile is blank *)
If[Extract[new,clickID[pt]]==0,
(* uncover tiles plus NNs.. *)
chainUncover,
(* else, uncover tile *)
show=ReplacePart[show,clickID[pt]->Extract[new,clickID[pt]]]],
(* if Shift Key is pressed *)
Which[
(* reveal NNs for uncovered tiles *)
Extract[show,clickID[pt]]=!="U"=!="F",show=ReplacePart[show,Normal[
AssociationThread[Keys[Select[AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[show,nn[clickID[pt][[1]],clickID[pt][[2]]]]],#1=="U"&]]->
Extract[new,#]&[Keys[Select[AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[show,nn[clickID[pt][[1]],clickID[pt][[2]]]]],#1=="U"&]]]]]],
(* toggle flags for covered tiles *) 
Extract[show,clickID[pt]]=="U",show=ReplacePart[show,clickID[pt]->"F"],
Extract[show,clickID[pt]]=="F",show=ReplacePart[show,clickID[pt]->"U"]
]
];)&],
(* CONTROL + DISPLAY *)
Row[{
Column[{
Control[{{gridLength,10,"Grid Size"},{10->"Small",20->"Medium",30->"Large"(*,40->"X Large"*)}}],
Control[{{mineProb,0.1,"Mine Density"},{0.05->"Beginner",0.1->"Easy",0.15->"Medium",0.25->"Hard",0.3->"Expert",0.4->"Pro"}}],Button[Dynamic@Which[lose==True,"You lose - Play Again?",win==True,"You Win - Play Again?",True, "Restart"],newGame]
}],
Panel[
Column[{
Row[{TextCell["Mines: "],Dynamic@Length[mines]}],
Row[{TextCell["Flags: "],Dynamic@Count[show,"F",2]}]
}]
]},Spacer[20]],
SaveDefinitions->True,
LocalizeVariables->False,
Initialization:>(
(*functions *)
clickID:={gridLength-#[[2]],1+#[[1]]}&;
chainUncover:=(
(*if click ID = 0 *)
stepNew=AssociationThread[nn[clickID[pt][[1]],clickID[pt][[2]]]->Extract[new,nn[clickID[pt][[1]],clickID[pt][[2]]]]];
show=ReplacePart[show,Normal[stepNew]];
stepOld=stepNew;
(* NNs of blank tiles from step 1 *)
Do[
stepNew=AssociationThread[Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]-> Extract[new,Flatten[nn[#[[1]],#[[2]]]&/@Keys[Select[#==0&]@stepOld],1]]];
show=ReplacePart[show,Normal[stepNew]];
stepOld=stepNew,
100]
);

nn=(*nearest neighbors *)Select[0<#[[1]]≤ gridLength&]@Select[0<#[[2]]≤ gridLength&]@{{#1-1,#2-1},{#1-1,#2},{#1-1,#2+1},{#1,#2-1},{#1,#2},{#1,#2+1},{#1+1,#2-1},{#1+1,#2},{#1+1,#2+1}}&;
grid=(*generate random starting grid*)RandomChoice[{#1,1-#1}-> {"m",0},{#2,#2}]&;
colRules=Join[
Normal[AssociationThread[Range[8]->(Rest[(Hue[1,#,1]&/@Rescale[Range[9]])])]],
{"m"->Hue[1,1,0],"U"->GrayLevel[0.8],"F"->RGBColor[0.2,0.5,0.7]}
];
(*win condition *)
win:=Position[show,"U"|"F"]==mines&&lose==False;
(* lose conditions *)
lose:=ContainsAny[Position[show,"m"],mines];
(* initialize *)
mineProb=0.1;gridLength=10;pt={0,0};
newGame:=(
label="Restart";
test=grid[mineProb,gridLength];
safe=(*array positions of safe tiles*)Position[test,0];
mines=(*array positions of mine tiles*)Position[test,"m"];
mineCount=(*number of NNs that are mines*)Table[Length[Flatten[Intersection[nn[First@safe[[#]],Last@safe[[#]]],mines]]]/2&[i],{i,1,Length[safe]}];
new=Replace[test,1->"m",2];
new=(*insert nn mine count*)ReplacePart[test,Table[safe[[i]]-> mineCount[[i]],{i,1,Length[safe]}]];
show=ConstantArray["U",Dimensions[new]];
index=Flatten[Table[{j,i},{i,gridLength,1,-1},{j,1,gridLength,1}],1];
tips=Table[Inset[(Style[#,Black,12,"Title"]&/@ToString/@(Flatten[new]/.{0->""}))[[i]],index[[i]]-0.5],{i,1,gridLength^2}];
);
newGame;
)
]

Optional Step: Deploy the Game with CDFDeploy

Finally, evaluate this to produce Minesweeper in CDF. It uses NotebookDirectory, so save this notebook first or define a file path:

CDFDeploy[FileNameJoin[{NotebookDirectory[],"MinesweeperClassic"}],minesweeperCDF,WindowSize->{540,660},Method->"Standalone"]

Side-Scroller: Castlevania (1986)

Development details

Get background

Import[FileNameJoin[{NotebookDirectory[],"Sprites","LevelMap.png"}]]

Get sprites

Many sprite maps can be found online.

http://spritedatabase.net

https://www.spriters-resource.com

Import[FileNameJoin[{NotebookDirectory[],"Sprites","SpriteMap.png"}]]

Start with cropped sequences:

ImageCrop/@RemoveBackground/@{,,}

ImageDimensions/@%

ImageCrop/@RemoveBackground/@{,,}

ImageCrop/@RemoveBackground/@{,,,}

ImageDimensions/@%

ImageCrop/@RemoveBackground/@{,,}

ImageDimensions/@%

Pad each image to get all of them to line up and be centered with respect to reflection. The final versions all have a size of {105,42}:

Manipulate[
With[{
im=ImagePad[,{{left,right},{bottom,top}},White],
im2=ImagePad[,{{left2,right2},{bottom2,top2}},White]},
Column[{
ImageDimensions[im],Framed[im,FrameMargins->None],
Framed[im2,FrameMargins->None],ImageDimensions[im2],
ListAnimate[{im,im2},4]
}]
],
{{left,43},-10,60,1},{{right,46},-10,60,1},{{bottom,9},-10,60,1},{{top,3},-10,60,1},
{{left2,0},-10,60,1},{{right2,0},-10,60,1},{{bottom2,0},-10,60,1},{{top2,0},-10,60,1},ControlType->LabeledSlider]

Size sprites

Manipulate[
Graphics[{Inset[walkingRight[[1]],{x,y},Scaled[{0.5,0.5}],size]},
Prolog->Inset[background,{0,0},Scaled[{0,0}],4.19],Frame->True,PlotRange->{{0,1.396},{0,1}},ImageSize->Large],
{x,0.1,0.4},{y,0.1,0.4},
{size,0.05,1},SaveDefinitions->True]

Sound and music

Retro game sounds can be found online.

https://www.sounds-resource.com

http://www.vgmusic.com

music=Import[FileNameJoin[{NotebookDirectory[],"Sounds","VamKill.mid"}]];

Do[sound[i]=Import[FileNameJoin[{NotebookDirectory[],"Sounds","0"<>ToString[i]<>".wav"}],"Sound"],{i,1,9}];
Do[sound[i]=Import[FileNameJoin[{NotebookDirectory[],"Sounds",ToString[i]<>".wav"}],"Sound"],{i,10,37}];

TabView[sound/@Range[37]]

Source Code

BeginPackage["Castlevania`"];

playLevel::usage="Play a demo of the first stage of the original Castlevania";

Begin["Private`"];


(* ==== SPRITES ==== *)
background=Import[FileNameJoin[{NotebookDirectory[],"Sprites","LevelMap.png"}]];
whippingLeft=RemoveBackground/@{ImagePad[,{{42,26},{5,1}},White],ImagePad[,{{41,26},{8,0}},White],ImagePad[,{{16,45},{9,4}},White],ImagePad[,{{44,45},{9,3}},White]};
duckWhippingLeft=RemoveBackground/@{ImagePad[,{{41,24},{-6,6}},White],ImagePad[,{{43,30},{8,11}},White],ImagePad[,{{15,46},{8,12}},White],ImagePad[,{{43,46},{8,11}},White]};
walkingLeft=RemoveBackground/@{ImagePad[,{{43,46},{9,3}}],ImagePad[,{{44,49},{9,2}},White],ImagePad[,{{43,47},{9,2}},White],ImagePad[,{{44,49},{9,2}},White]};
duckLeft=RemoveBackground[ImagePad[,{{43,46},{8,11}},White]];
whippingRight=ImageReflect[#,Right]&/@whippingLeft;
duckWhippingRight=ImageReflect[#,Right]&/@duckWhippingLeft;
walkingRight=ImageReflect[#,Right]&/@walkingLeft;
duckRight=ImageReflect[duckLeft,Right];
whipSound=sound[10];
hitSound=sound[20];


(* ==== SOUNDS ==== *)
music=Import[FileNameJoin[{NotebookDirectory[],"Sounds","VamKill.mid"}]];
Do[sound[i]=Import[FileNameJoin[{NotebookDirectory[],"Sounds","0"<>ToString[i]<>".wav"}],"Sound"],{i,1,9}];
Do[sound[i]=Import[FileNameJoin[{NotebookDirectory[],"Sounds",ToString[i]<>".wav"}],"Sound"],{i,10,37}];


(* ==== MAIN ==== *)
playLevel[]:=DynamicModule[{im=walkingRight[[1]],playerDir=Right,playerDuck=False,scrollPos=0,scrollSpeed=0.01,playerX=0.288,playerY=0.282,playerYtemp=0.282,playerYvel=0,grav=0.01,screenWidth=1.396,mapEdge=3.4,playerAnimationCounter=1,playerFrame=1,whipFrame=1,whipAnimationCounter=1,pause=0.01,jumpTask},
(* start background music *)
EmitSound[music];

EventHandler[

(* main graphics with dynamic PlotRange *)
Graphics[{Inset[Dynamic[im],{Dynamic@playerX,
Dynamic[First[{playerY}]]},
Scaled[{0.5,0.5}],0.562]},
Prolog->Inset[background,{0,0},Scaled[{0,0}],4.19],
Frame->False,
ImageSize->Large,
PlotRange->{{Dynamic[0+scrollPos],Dynamic[screenWidth+scrollPos]},{0,1}},
PlotRangePadding->None],

(* key actions *)
{"LeftArrowKeyDown":>(
If[playerDir===Right,
playerDir=Left;
If[playerDuck,
im=duckLeft,
playerAnimationCounter=9;im=walkingLeft[[playerFrame]]
],
playerDuck=False;im=walkingLeft[[playerFrame]]
];
playerAnimationCounter+=1;
If[playerX>0.07,playerX-=scrollSpeed];
If[scrollPos>0&&(scrollPos+screenWidth/2.3>playerX),scrollPos-=scrollSpeed];
If[Mod[playerAnimationCounter,10]==0,
playerAnimationCounter=1;
im=walkingLeft[[If[playerFrame==4,playerFrame=1,++playerFrame]]]
]),

"RightArrowKeyDown":>(
If[playerDir===Left,
playerDir=Right;
If[playerDuck,
im=duckRight,
playerAnimationCounter=9;im=walkingRight[[playerFrame]]
],
playerDuck=False;im=walkingRight[[playerFrame]]
];
playerAnimationCounter+=1;
If[playerX<3.5,playerX+=scrollSpeed];
If[scrollPos<2.7&&((scrollPos+screenWidth)/2.4<playerX),scrollPos+=scrollSpeed];
If[Mod[playerAnimationCounter,10]==0,
playerAnimationCounter=1;
im=walkingRight[[If[playerFrame==4,playerFrame=1,++playerFrame]]]
]),

"DownArrowKeyDown":>(
If[!playerDuck,playerDuck=True;If[playerDir===Left,im=duckLeft,im=duckRight]]
),

"UpArrowKeyDown":>(
If[playerDuck,
playerDuck=False;
If[playerDir===Left,
im=walkingLeft[[playerFrame]],
im=walkingRight[[playerFrame]]
]
]
),

(* whip key *)
{"KeyDown","z"}:>(
EmitSound[whipSound];
Switch[{playerDuck,playerDir===Left},
{False,True},
Do[
If[Mod[i,1000]==0,im=whippingLeft[[i/1000]]];
FinishDynamic[],{i,1000,4000}
];
im=walkingLeft[[playerFrame]],

{False,False},
Do[
If[Mod[i,1000]==0,im=whippingRight[[i/1000]]];
FinishDynamic[],{i,1000,4000}
];
im=walkingRight[[playerFrame]],

{True,True},
Do[
If[Mod[i,1000]==0,im=duckWhippingLeft[[i/1000]]];
FinishDynamic[],{i,1000,4000}
];
im=duckLeft,

{True,False},
Do[
If[Mod[i,1000]==0,im=duckWhippingRight[[i/1000]]];
FinishDynamic[],{i,1000,4000}
];
im=duckRight
]
),

(* jump key *)
{"KeyDown","x"}:>(playerYvel=0.05;)
}
],

SaveDefinitions->True,

Initialization:>(
jumpTask=CreateScheduledTask[
playerYvel-=grav;
playerY+=playerYvel;
If[playerY<0.282,playerY=0.282;playerYvel=0;],
0.1
];
StartScheduledTask[jumpTask];)
]

End[];

EndPackage[];

Play

playLevel[]

Using External Gamepads

ControllerInformation[]

Dynamic[ControllerState[{"X1","Y1"}]]

Dynamic[ControllerState[{"X2","Y2"}]]

Dynamic[ControllerState[{"X3","Y3"}]]

Dynamic[ControllerState[{"B1","B2","B3","B4"}]]

Dynamic[ControllerState[{"Left Bumper Button","Right Bumper Button"}]]

Dynamic[ControllerState[{"Slider","Slider 2"}]]

Basic 2D Side-Scroller Creator

Development Steps

Hit detection

createTile[pos:{x_Integer,y_Integer},col_,onoff_]:=<|
"Position"->pos,
"BlockPoints"->{pos,pos+{0,0.5},pos+{0,1},pos+{0.5,1},pos+{1,1},pos+{1,0.5},pos+{1,0},pos+{0.5,0}},
"xmin"->x,
"xmax"->x+1,
"ymin"->y,
"ymax"->y+1,
"Color"->col,
"Obj"->onoff
|>

Add mouse-click control

removeBlock[mp_,blocks_,blockPoints_]:=(
With[{p=Nearest[Values@blocks[[All,{"xmin","ymin"}]]->"Index",mp-{0.5,0.5}][[1]]},
If[blocks[[p,"Obj"]]==True,
blocks[[p,"Color"]]=White;
blocks[[p,"Obj"]]=False;
]
];
blockPoints=DeleteDuplicates[Join@@Select[blocks,#Obj==True&][[All,"BlockPoints"]]];
)
SetAttributes[removeBlock,HoldRest];

addBlock[mp_,blocks_,blockPoints_]:=(
With[{p=Nearest[Values@blocks[[All,{"xmin","ymin"}]]->"Index",mp-{0.5,0.5}][[1]]},
If[blocks[[p,"Obj"]]==False,
blocks[[p,"Color"]]=LightBlue;
blocks[[p,"Obj"]]=True;
blockPoints=DeleteDuplicates@Join[blockPoints,blocks[[p,"BlockPoints"]]];
]
]
)
SetAttributes[addBlock,HoldRest];

Main Code with Gravity and Jumping

BeginPackage["SideScrollMaker`"];

makeGame::usage="Start the side-scroll maker demo.";

Begin["Private`"];
createTile[pos:{x_Integer,y_Integer},col_,onoff_]:=<|
"Position"->pos,
"BlockPoints"->{pos,pos+{0,0.5},pos+{0,1},pos+{0.5,1},pos+{1,1},pos+{1,0.5},pos+{1,0},pos+{0.5,0}},
"xmin"->x,
"xmax"->x+1,
"ymin"->y,
"ymax"->y+1,
"Color"->col,
"Obj"->onoff
|>

removeBlock[mp_,blocks_,blockPoints_]:=(
With[{p=Nearest[Values@blocks[[All,{"xmin","ymin"}]]->"Index",mp-{0.5,0.5}][[1]]},
If[blocks[[p,"Obj"]]==True,
blocks[[p,"Color"]]=White;
blocks[[p,"Obj"]]=False;
]
];
blockPoints=DeleteDuplicates[Join@@Select[blocks,#Obj==True&][[All,"BlockPoints"]]];
)
SetAttributes[removeBlock,HoldRest];

addBlock[mp_,blocks_,blockPoints_]:=(
With[{p=Nearest[Values@blocks[[All,{"xmin","ymin"}]]->"Index",mp-{0.5,0.5}][[1]]},
If[blocks[[p,"Obj"]]==False,
blocks[[p,"Color"]]=LightBlue;
blocks[[p,"Obj"]]=True;
blockPoints=DeleteDuplicates@Join[blockPoints,blocks[[p,"BlockPoints"]]];
]
]
)
SetAttributes[addBlock,HoldRest];


makeGame[] := DynamicModule[{mp={0,0},blocks,blockPoints={},playerVelX=1/10,playerVelY=1/10,playerX=3,playerY=6,gravity,grav=0.01,previousState=False,jumpCounter=0},

blocks=Flatten[Table[createTile[{i,j},White,False],{i,0,10},{j,0,10}]];
addBlock[#,blocks,blockPoints]&/@Table[{i,0.3},{i,1,11}];

EventHandler[
Graphics[{
Table[With[{i=i},{EdgeForm[Black],Dynamic[FaceForm[blocks[[i,"Color"]]]],Rectangle[Values@blocks[[i,{"xmin","ymin"}]],Values@blocks[[i,{"xmax","ymax"}]]]}],{i,Length[blocks]}],
{EdgeForm[Darker[Orange]],FaceForm[Orange],Rectangle[
Dynamic[
With[{p={playerX+playerVelX*ControllerState["X3"],playerY+playerVelY*ControllerState["Y3"]}},
If[!AnyTrue[{p,p+{0,1}},Function[{x},Or@@(x[[1]]<#[[1]]<x[[1]]+1&&x[[2]]<#[[2]]<x[[2]]+1&/@blockPoints)]],{playerX,playerY}=p]
];
{playerX,playerY}
],
{Dynamic[playerX+1],
Dynamic[
Switch[{previousState,ControllerState["B1"]},
{False,True},If[jumpCounter<2,jumpCounter+=1;playerVelY=0.2;previousState=True;];,
{True,False},previousState=False;
];
playerY+2]}
]}
},
Frame->True,PlotRangePadding->None,ImageSize->Medium],

{"MouseMoved":>(mp=MousePosition["Graphics"]),

"MouseClicked":>(
If[CurrentValue["ShiftKey"],
removeBlock[mp,blocks,blockPoints],
addBlock[mp,blocks,blockPoints]
]),

"MouseDragged":>(
If[CurrentValue["ShiftKey"],
removeBlock[mp,blocks,blockPoints],
addBlock[mp,blocks,blockPoints]
])
}
],

Initialization:>(
gravity=CreateScheduledTask[
playerVelY-=grav;
With[{p=playerY+playerVelY},
If[!AnyTrue[{{playerX,p},{playerX,p+1}},Function[{x},Or@@(x[[1]]<#[[1]]<x[[1]]+1&&x[[2]]<#[[2]]<x[[2]]+1&/@blockPoints)]],
playerY=p,
jumpCounter=0;playerVelY=0;
]
],
0.01
];
StartScheduledTask[gravity];)
]

End[];

EndPackage[];

makeGame[]

RemoveScheduledTask[ScheduledTasks[]]

Modern Games: Flappy Bird (2013)

You can download the full game from my GitHub account: https://github.com/KMDaily/FlappyBird_Mathematica/blob/master/FlappyBird.zip.

My post on Wolfram Community: http://community.wolfram.com/groups/-/m/t/1127985.

Development Steps

Projectile based on updating velocity

DynamicModule[{pos=0,vel=0},
Column[{
Graphics[
{
Line[{{-5,-1},{5,-1}}],
Circle[{0,Dynamic[
vel-=1;pos+=vel;If[pos<0,vel=pos=0];
pos]},1]
},
PlotRange->{{-5,5},{-5,15}},Frame->True
],
Button["JUMP",vel=10],
Dynamic[{pos,vel}]
}]
]

Controlling update rate (frames per second)

RemoveScheduledTask/@ScheduledTasks[];

DynamicModule[{task,pos=0,vel=0,fps=30,gravity=100,kick=10},
Column[{
Graphics[{Line[{{-5,-1},{5,-1}}],Dynamic[Circle[{5,pos},0.5]]},
Frame->True,PlotRange->{{0,10},{0,14}},ImageSize->200
],
Button["JUMP",vel=kick/fps],
Dynamic[{pos,vel}],
LabeledSlider[Dynamic[gravity],{100,3000}],
LabeledSlider[Dynamic[kick],{1,1500}]
}],
Initialization:>(
task=CreateScheduledTask[
vel-=gravity/fps/fps;
pos+=(1/2) vel/fps;
If[pos<0,vel=pos=0];
,
1./fps
];
StartScheduledTask[task];)
]

Using keyboard controls

Using CurrentValue of a key:

Dynamic[CurrentValue["ControlKey"]]

Using a check that button was not held:

Switch[{previousButtonState,CurrentValue["ControlKey"]},
{False,True},previousButtonState=True;vel=kick/fps,
{True,False},previousButtonState=False,
_,Null
]

Introduce obstacles

Use Manipulate to determine pipe locations:

Manipulate[
Graphics[{
Line[{{0,0},{0,h},{w2,h},{w2,0},{0,0}}],Line[{{0,h+w},{0,50+h},{w2,50+h},{w2,h+w},{0,h+w}}]},Frame->True,PlotRange->{{0,10},{0,14}},ImageSize->200],
{{h,4.5},0,14},
{{w,3.4},1,15},
{{w2,2},2,10}]

Making a series of random pipes:

createPipe[h_,w_,w2_,p0_]:={
Line[{{p0,0},{p0,h},{w2+p0,h},{w2+p0,0},{p0,0}}],Line[{{p0,h+w},{p0,20+h},{w2+p0,20+h},{w2+p0,h+w},{p0,h+w}}]}

Graphics[Table[createPipe[RandomReal[{1,10}],3.4,2,i],{i,15,100,7.5}]]

Collisions

Can use RegionIntersection of a line (outline) that defines each object:

test=Line/@{
{{0,0},{1,0},{1,1},{0,1},{0,0}},
{{0,2},{2,2},{2,0},{1,0},{1,1},{0,1},{0,2}}
};

Manipulate[
Column[{
RegionIntersection[Disk[{0,y}],#]&/@test,
Row[{Graphics[{Circle[{0,y}],test[[1]]}],Graphics[{Circle[{0,y}],test[[2]]}]}]
}],{y,-2,10},SaveDefinitions->True]

In practice, it is easier to directly calculate the distance from a point to a rectangle.

Add prettier graphics

Get the image sizes right:

With[{invertPipeImage=,pipeImage=,ground=,
pipeList={
createPipe[RandomReal[{1,10}],3.4,2,5],createPipe[RandomReal[{1,10}],3.4,2,12.5]
}},

Manipulate[
Graphics[{
Line[{{-5,-1},{45,-1}}],
{Red,Thick,pipeList},
Inset[invertPipeImage,pipeList[[1,2,1,1]],Scaled[{0,0}],size],
Inset[pipeImage,pipeList[[1,1,1,2]],Scaled[{0,1}],size],
{Red,Thick,Circle[{5,pos},0.5]},
Inset[,{5,pos},Scaled[{0.5,0.5}],a]
},
Frame->True,PlotRange->{{0,10},{0,14}},ImageSize->200,
Background->RGBColor[{0.44313725490196076`,0.7803921568627451`,0.8156862745098039`}],
Epilog->{Inset[ground,{-10,-0.6},Scaled[{0,1}],a]}
],
{pos,0,15},{{a,1},1,3},{{size,2.05},1,3},ControlPlacement->Bottom]
]

Add animations

gifSequence=RemoveBackground/@{,,,};

ListAnimate[gifSequence,AnimationRate->4,ImageSize->Small]

Add sound effects

flapSound=;
hurtSound=;
scoreSound=;

Final Optimized Code

SetDirectory[NotebookDirectory[]];
<<"FlappyBird.wl"

Play

playFlappyBird[]

Modern Games: Minecraft Classic (2009)

This code is taken verbatim from these posts:

https://mathematica.stackexchange.com/questions/19669/mathematica-minecraft

http://community.wolfram.com/groups/-/m/t/814988

First, quit the kernel to free up space:

Quit[]

Source 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=True;
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[]

Additional References

CellPrint[ExpressionCell[
Grid[{
{Hyperlink["Circle Pong","http://blog.wolfram.com/2016/11/09/the-2016-wolfram-one-liner-competition-winners"],
Hyperlink["Minesweeper","http://community.wolfram.com/groups/-/m/t/847797"]},
{Hyperlink["Minesweeper on hexagonal grid","http://community.wolfram.com/groups/-/m/t/848008"],
Hyperlink["Solving Suguru (Tectonic) Puzzles","http://community.wolfram.com/groups/-/m/t/1077888"]},
{Hyperlink["Fun with Anagrams","http://blog.wolfram.com/2008/07/25/word-combinatorics/"],
Hyperlink["Solving Hidato/Numbrix Puzzles","http://community.wolfram.com/groups/-/m/t/892653"]},
{Hyperlink["Tetris","http://community.wolfram.com/groups/-/m/t/879149"],
Hyperlink["Minecraft","http://community.wolfram.com/groups/-/m/t/814988"],""}
},BaseStyle->{FontWeight->Bold,FontFamily->"Helvetica"},Alignment->Left,Spacings->{7, 1}],"Output",GeneratedCell->False]]