3-D Game Development in Wolfram Language

Kevin Daily, Wolfram Research

(RowDefault[, (Spacer1), , (Spacer1), ])  #WolframTechConf

Abstract

Discover the possibilities of game development solely within Wolfram Notebooks. Our main focus is to guide you through the process of creating a first-person gaming experience using Graphics3D and Dynamic. We will explore essential techniques such as camera control, integration with external game controllers, collision detection, and line-of-sight mechanics.

Wolfram Notebooks as a game engine

A game engine is an interface that assists in building and playing games, including

graphics

physics

user input

collision detection

animation, sound, etc.

The tools to create games can be built up with the Wolfram Language and the games run in a Notebook.

(R&D Talk) Wolfram Notebooks as a Game Engine — Kevin Daily — May 10, 2023

Preview

"Initialize notebook code"

Features and resources

Graphics3D[…, Method -> {…}]

"CacheAllTextures" -> True

"TextureSampling" -> "Nearest"

"EdgeDepthOffset" -> "False"

ResourceFunction["ImportOBJ"]

Similar to Import[…, "OBJ"]

Data includes both mesh and Texture data

Graphics3D

Our game takes place in a Graphics3D expression with geometric primitives.

Graphics3D[
{Purple,Sphere[{3, 2,4},0.5],Cuboid[{1,1,1},{2,2,2}],AbsoluteThickness[3],Line[{{1,4,3},{1,4,1}}],Polygon[{{2,2,0},{2,4,0},{4,4,0.5},{4,2,0.5}}]},
Axes -> True, AxesLabel->{"x","y","z"},FaceGrids->{{0,0,-1},{-1,0,0},{0,1,0}},ImageSize->Scaled[0.33],PlotRange->{{0,5},{0,5}, {0, 5}}]

Dynamic is the driver

We create a runaway Dynamic evaluation to drive the apparent motion of game objects.

Basic principles

Dynamic

The goal of Dynamic[expr] is to display expr as it is right now.

x=0.5;

Dynamic[x]

Slider[Dynamic[x],{0,4}]

DynamicWrapper

As long as the first argument is visible on screen, the second argument evaluates.

DynamicWrapper[Button[Dynamic[x],x=0],x++]

DynamicModule

Localize variables to prevent dynamic interfaces from cross-communicating.

DynamicModule[{x=0},
DynamicWrapper[
Dynamic[Hue[x]],
x += 0.001 ]]

Demo: shuffleboard

DynamicModule[{x = 0, vel = 0, acc = 0.1, dec = 0.02, $TimeFactor = 0.3},
	DynamicWrapper[
		Column[{
			,
			Graphics3D[
				{, Cylinder[Dynamic[{{x, 0, 0.5}, {x, 0, 1}}]]},
				]}],
		If[CurrentValue["ControlKey"] && x < 10,
			vel += acc*$TimeFactor; x += vel*$TimeFactor
			, (* ELSE *)
			vel -= dec*$TimeFactor; If[vel < 0, vel = 0]; x += vel*$TimeFactor]]]

Camera: ViewAngle, ViewVector and ViewVertical

There are other ways to control the camera but I find these options the easiest to understand. Some neat community examples include Understanding Graphics3D’s view options: the intuitive way by Silvia Hao and Glam-ifying 3D graphics by Anika Patel.

(Bonus) Define cube and camera pyramid primitives

centerCube = Cuboid[{-1, -1, 0}, {1, 1, 2}];

pyramidPts[camera_, aim_, angle_, edgeLength_] :=
Module[{vv, tmv, a = angle/2},
	vv = Normalize[aim - camera]; (* unit ViewVector *)
	tmv = {vv[[2]], -vv[[1]], 0};    (* transverse vector *)
	{
		camera + edgeLength*RotationMatrix[ a Degree, Cross[tmv, vv]].RotationMatrix[ a Degree, tmv].vv,
		camera + edgeLength*RotationMatrix[-a Degree, Cross[tmv, vv]].RotationMatrix[ a Degree, tmv].vv,
		camera + edgeLength*RotationMatrix[-a Degree, Cross[tmv, vv]].RotationMatrix[-a Degree, tmv].vv,
		camera + edgeLength*RotationMatrix[ a Degree, Cross[tmv, vv]].RotationMatrix[-a Degree, tmv].vv,
		camera}]

Demo

DynamicModule[{camera = {-3, -3, 1}, aim = {-2, -2, 1}, d = 45},
	Grid[{
		{"Outside POV", "Camera POV"},
		{
			Graphics3D[
				{centerCube, Opacity[0.2`], Purple, Pyramid[Dynamic[pyramidPts[camera, aim, d, 10d]]]},
				],
			Graphics3D[centerCube,
				ViewAngle -> Dynamic[d Degree],
				ViewVector -> {camera, aim},
				ViewVertical -> {0, 0, 1}, (* yaw *)
				] // Deploy},
		{, SpanFromLeft}}]]

Camera: move

Let’s start to manipulate the camera by keeping it facing the same direction but moving its location.

Two movement vectors

(Subscript[Y, B]): forward/backward, projection of ViewVector onto plane

(Subscript[X, B]): left/right sideways, perpendicular of (Subscript[Y, B]) (transverse direction)

Demo

DynamicModule[{camera = {-5, -5, 1}, aim = {-4, -4, 1}, vv, fmv, tmv, fb = 0, lr = 0},
	vv = Normalize[aim - camera];        (* unit-length ViewVector *)
	fmv = Normalize[{vv[[1]], vv[[2]], 0}];  (* unit-length forward motion vector *)
	tmv = {fmv[[2]], -fmv[[1]], 0};          (* unit-length transverse motion vector *)
	Grid[{
		{"Outside POV", "Camera POV"},
		{
			,
			Graphics3D[centerCube,
				ViewVector -> Dynamic[{camera + fb*fmv + lr*tmv, aim + fb*fmv + lr*tmv}],
				] // Deploy},
		{, SpanFromLeft}}]]

Camera: look around

Let’s keep the camera fixed but pivot to look around the scene.

Rotation around two vectors

(Subscript[X, B]): up/down (pitch)

(Subscript[Z, B]): left/right (yaw)

(Bonus) Rotation functions

Rotation around (Subscript[Z, B]) is simple:

leftRightRotation[ϕ_] := Evaluate @ RotationMatrix[-ϕ, {0, 0, 1}]

Rotation around (Subscript[X, B]) is less simple:

upDownRotation[θ_, {fmvX_, fmvY_, fmvZ_}] := Evaluate @
FullSimplify[
	RotationMatrix[θ, {fmvY, -fmvX, 0}], (* (Subscript[X, B]) rotation *)
	And[fmvX ∈ Reals, fmvY ∈ Reals, (fmvX^2) + (fmvY^2) == 1]]

Demo

DynamicModule[{camera = {-5., -5., 1.}, aim = {-4, -4, 1}, θ = 0, ϕ = 0, vv, fmv, vvNew},
	vv = Normalize[aim - camera];
	fmv = Normalize[{vv[[1]], vv[[2]], 0}];
	Grid[{
		{"Outside POV", "Camera POV"},
		{
			,
			Graphics3D[centerCube,
				ViewVector -> Dynamic[{camera, camera + (vvNew = leftRightRotation[ϕ].upDownRotation[θ, fmv].vv)}],
				] // Deploy},
		{, SpanFromLeft}},
		Alignment -> {Left, Center}]]

User input

ControllerInformation

ControllerInformation[]

ControllerState

Dynamic[ControllerState[{"XY1","XY2","Z"}]]

controllerReadyQ

controllerReadyQ[display_] :=
PaneSelector[
	{True -> "No controller connected.", False -> display},
	Dynamic[FailureQ[ControllerState["X Axis"]]],
	ImageSize -> Automatic]

noDrift

noDrift[val_] := Chop[val, 0.15]

Dynamic[noDrift[ControllerState[{"XY1","XY2","Z"}]]]

User input: camera control

Free movement

(Bonus) upDownRotationSafe

The end points of the pitch rotation are problematic. If we’re no longer facing along the forward-motion vector then don’t accept the rotation.

upDownRotationSafe[θ_, fmv_, vv_] :=
Function[attempt, If[attempt.fmv >= 0, attempt, vv]][upDownRotation[θ, fmv].vv]

freeMovement

Attributes[freeMovement] = {HoldFirst};

freeMovement[
	(*HELD*) {controls_ControllerState, viewVector_},
	(*FREE*) $TimeFactor_, vel_, velRot_
] :=
Module[{vv, fmv, tmv, xyAxis, xRot, yRot, z, disp, aim},
	{xyAxis, {xRot, yRot}, z} = noDrift[controls];
	vv = Normalize[viewVector[[2]] - viewVector[[1]]];
	fmv = Normalize[{vv[[1]], vv[[2]], 0}];
	tmv = {fmv[[2]], -fmv[[1]], 0};
	
	disp = $TimeFactor*vel*(xyAxis.{tmv, fmv} + {0, 0, z});
	aim =
		Dot[
			leftRightRotation[$TimeFactor*velRot*xRot],
			upDownRotationSafe[$TimeFactor*velRot*yRot, fmv, vv]];
	
	viewVector = {viewVector[[1]] + disp, viewVector[[1]] + disp + aim}]

Demo: floating cubes

cubes=Table[{RandomColor[], Cuboid[{#1,#2,#3}, {#1,#2,#3}+{1,1,1}]&[RandomInteger[{-30,30}],RandomInteger[{-30,30}],RandomInteger[{0,30}]]}, {i,400}];

DynamicModule[{$TimeFactor = 0.04, vDisp = 10, vRot = 1, viewVector},
	viewVector = {{1.5, 1.5, 2.75}, {2.207, 2.207, 2.75}};
	DynamicWrapper[
		Graphics3D[
			{InfinitePlane[{{0, 0, 0}, {1, 0, 0}, {0, 1, 0}}], cubes},
			] // Deploy,
		freeMovement[
			{ControllerState[{"XY1", "XY2", "Z"}], viewVector},
			$TimeFactor, vDisp, vRot]]
] // controllerReadyQ

Graphics3D: a world of textured polygons

Refresher on using Texture with Polygon

Introduction

polySet={
(* typical corner-to-corner *)
Polygon[,VertexTextureCoordinates->{{0,0},{1,0},{1,1},{0,1}}],
(* forced reptition of pattern *)
Polygon[,VertexTextureCoordinates->{{-1,0},{3,0},{3,1},{-1,1}}],
(* smaller cut-out *)
Polygon[, VertexTextureCoordinates -> {{0.1, 0.1}, {0.5, 0.1}, {0.5, 0.7}, {0.1, 0.7}}]};

texture=ExampleData[{"Texture","Bricks"}];

Graphics3D[{Texture[texture],polySet},ViewPoint->Front,Lighting->{{"Ambient", White}}]

Low-pixel count

examplePolygon=Polygon[{{0,0},{1,0},{1,1},{0,1}},VertexTextureCoordinates->{{0,0},{1,0},{1,1},{0,1}}];
lowResTexture=RandomImage[{0.5,1},4,ColorSpace->"RGB"]

Graphics[{Texture[lowResTexture],examplePolygon}]

Graphics[{Texture[lowResTexture],examplePolygon},Method->{"TextureSampling"->"Nearest"}]

Multiple textures

textureSet=Texture/@{ExampleData[{"Texture","Wood"}],ExampleData[{"Texture","Bark"}],ExampleData[{"Texture","Grass"}]};Graphics3D[Thread[{textureSet,polySet}],ViewPoint->Front,Lighting->{{"Ambient", White}}]

14.0+: "CacheAllTextures" -> True

Graphics3D[Thread[{textureSet,polySet}],Method-> {"CacheAllTextures" -> True},
ViewPoint->Front,Lighting->{{"Ambient", White}}]

(Bonus) 13.3-: One Texture to rule them all...

Canonicalize the VertexTextureCoordinates

Adjust the bottom-left of the cut-out such that it starts in the positive coordinate space, i.e. somewhere in the range 0 to 1.

normalizeVTC[multiset:{{{_?NumericQ, _?NumericQ}..}..}] := normalizeVTC /@ multiset

normalizeVTC[set:{{_?NumericQ, _?NumericQ}..}] :=
ReplaceRepeated[
	set,
	{
		s:{{_, _}..} :> Map[# + {0, 1}&, s] /; AnyTrue[s[[All, 2]], # < 0&],
		s:{{_, _}..} :> Map[# + {1, 0}&, s] /; AnyTrue[s[[All, 1]], # < 0&],
		s:{{_, _}..} :> Map[# - {0, 1}&, s] /; AllTrue[s[[All, 2]], # >= 1&],
		s:{{_, _}..} :> Map[# - {1, 0}&, s] /; AllTrue[s[[All, 1]], # >= 1&]}]

reformattedCoords=normalizeVTC/@Cases[polySet,HoldPattern[VertexTextureCoordinates->v_]:>v,Infinity];

If a texture’s coordinates extend beyond 1 then ImageAssemble as necessary

repetitionCounts=Ceiling[Apply[Max,Transpose[Cases[#,{x_?NumericQ,y_?NumericQ}:>{x,y},Infinity]]&/@reformattedCoords,{2}]];

reformattedImages=MapThread[ImageAssemble[Table[#1[[1]],#2[[2]],#2[[1]]]]&,{textureSet,repetitionCounts}];

reformattedCoords = MapThread[#1/.{x_?NumericQ,y_?NumericQ}:>{x,y}/#2&,{reformattedCoords,repetitionCounts}];

Set all fully-transparent pixels to the same value

This step makes it easier to find the lower-left corners of the following ImageCollage. Note: this example uses the RGB colorspace.

reformattedImages=ImageApply[If[#[[4]] == 0, {0, 0, 0, 0}, #]&,SetAlphaChannel[#]]&/@reformattedImages;

ImageCollage the full-size images with “ClosestPacking”

Use the same transparent color as in the above step.

collage=ImageCollage[(Scaled[1]->#)&/@reformattedImages,"Fit",Method->"ClosestPacking",Background->RGBColor[0,0,0,0]]

Brute-force function to find the lower-left corner of an image within the collage

ClearAll[findLowerLeftCorner];
findLowerLeftCorner[i1_Image, i2_Image] :=
Module[{possibilities, W, H, w, h, blc, brc, tlc, trc, temp1, temp2},
	(* get image dimensions and corner colors *)
	{W, H} = ImageDimensions[i1]; (* used in final ImageTake *)
	{w, h} = ImageDimensions[i2];
	{blc, brc, tlc, trc} = PixelValue[i2, {{1, 1}, {w, 1}, {1, h}, {w, h}}];
	(* pare down the possibilities *)
	possibilities = PixelValuePositions[i1, blc, 0.001];
	possibilities =
		Extract[
			possibilities,
			Position[
				Chop[Map[#-brc&, PixelValue[i1, Map[{#[[1]]+w-1, #[[2]]}&, possibilities]]], 10^-5],
				{0, 0, 0, 0}]];
	If[Length[possibilities] < 2, Return[First[possibilities, None]]];
	possibilities =
		Extract[
			possibilities,
			Position[
				Chop[Map[#-tlc&, PixelValue[i1, Map[{#[[1]], #[[2]]+h-1}&, possibilities]]], 10^-5],
				{0, 0, 0, 0}]];
	If[Length[possibilities] < 2, Return[First[possibilities, None]]];
	possibilities =
		Extract[
			possibilities,
			Position[
				Chop[Map[#-trc&, PixelValue[i1, Map[{#[[1]]+w-1, #[[2]]+h-1}&, possibilities]]], 10^-5],
				{0, 0, 0, 0}]];
	If[Length[possibilities] < 2, Return[First[possibilities, None]]];
	(* brute force compare all pixels if ambiguity remains after comparing the four corners *)
	possibilities =
		Select[
			possibilities,
			Function[
				temp1 = ImageTake[i1, {(H-#[[2]]+1)-h+1, H-#[[2]]+1}, {#[[1]], #[[1]]+w-1}];
				And[
					ImageDimensions[temp1] === ImageDimensions[i2],
					temp2 = Union[Flatten[ImageData[temp1] - ImageData[i2], 1]];
					Length[temp2] == 1,
					AllTrue[First[temp2], # == 0. &]]](*With[{t = Union[Flatten[
				(ImageData[ImageTake[i1, {(H-#[[2]]+1)-h+1, H-#[[2]]+1}, {#[[1]], #[[1]]+w-1}]] -
				 ImageData[i2]),
				1] 
			]}, Length[t] == 1 && AllTrue[First[t], # == 0. &]]&*)];
	First[possibilities, None]
]

One Texture, multiple polygons

corners=findLowerLeftCorner[collage,#]&/@reformattedImages;
dimensions=ImageDimensions/@reformattedImages;
collageDimension=1.*ImageDimensions[collage];

reformattedCoords=MapThread[#1/.{x_?NumericQ,y_?NumericQ}:>({x,y}*#2+#3)/collageDimension&,{reformattedCoords,dimensions,corners}];

reformattedPolygons=MapThread[Replace[#1,HoldPattern[VertexTextureCoordinates->v_]:>VertexTextureCoordinates->#2,1]&,{polySet,reformattedCoords}];

Graphics3D[{Texture[collage],reformattedPolygons},ViewPoint->Front]

(Optional) Merge polygons into a single multi-Polygon

Because we have one texture, why not also merge all polygons into a single multi-Polygon?

oneToRuleThemAll=Polygon[#[[1]],VertexTextureCoordinates->#[[2]]]&[Join@@@Transpose@Cases[test,Polygon[pts_,___,VertexTextureCoordinates->v_,___]:>{If[Length[Dimensions[pts]]==2,{pts},pts],If[Length[Dimensions[v]]==2,{v},v]}]];

Graphics3D[{Texture[collage],oneToRuleThemAll},ViewPoint->Front]

Collision detection: GJK algorithm

The Gilbert–Johnson–Keerthi algorithm efficiently detects the distance between two convex objects. A good explanation can be found on the YouTube@Reducible channel.

impactQ[obj1_, obj2_] :=

(Bonus) Support functions

impactQ

impactQ[obj1_, obj2_] :=
Module[{ms, d, newPt},
	ms = {supportPoint[obj1, obj2, {1, 0, 0}]};
	d = -ms[[1]];
	Catch[
		While[True,
			newPt = supportPoint[obj1, obj2, d];
			If[newPt == {0., 0., 0.}, Throw[True, "HitQ"]];
			If[newPt.d < 0, Throw[False, "HitQ"], AppendTo[ms, newPt]];
			{ms, d} = doSimplex[ms]]
		,
		"HitQ"]]

supportPoint

The support function finds the furthest point on an object along a specified direction.

ClearAll[supportPoint]

(* multiple points assuming they make up a convex hull *)
supportPoint[objPoints:{{_, _, _}..}, dVec_] := TakeLargestBy[N[objPoints], Dot[#, dVec]&, 1][[1]]

(* 2D polygon embedded in 3D *)
supportPoint[Polygon[pts_, ___], dVec_] := supportPoint[pts, dVec]

(* polyhedron *)
supportPoint[Polyhedron[pts_, ___], dVec_] := supportPoint[pts, dVec]

(* sphere at a point with a radius *)
supportPoint[Sphere[{x_, y_, z_}, r_], dVec_] := N[{x, y, z} + Normalize[dVec]*r]

(* various cylinder syntax *)
supportPoint[Cylinder[], dVec_] := supportPoint[Cylinder[{{0, 0, -1}, {0, 0, 1}}, 1], dVec]

supportPoint[Cylinder[{pt1_, pt2_}], dVec_] := supportPoint[Cylinder[{pt1, pt2}, 1], dVec]

supportPoint[Cylinder[{pt1_, pt2_}, r_], dVec_] :=
Module[{projectedVecOnEndcaps, cap1, cap2},
	projectedVecOnEndcaps = r*Normalize[Cross[pt1 - pt2, Cross[dVec, pt1 - pt2]]];
	cap1 = pt1 + projectedVecOnEndcaps;
	cap2 = pt2 + projectedVecOnEndcaps;
	If[dVec.cap1 > dVec.cap2, cap1, cap2]]

(* various capsule shape syntax *)
supportPoint[CapsuleShape[], dVec_] := supportPoint[CapsuleShape[{{-1, 0, 0}, {1, 0, 0}}, 1], dVec]

supportPoint[CapsuleShape[r_], dVec_] := supportPoint[CapsuleShape[{{-1, 0, 0}, {1, 0, 0}}, r], dVec]

supportPoint[CapsuleShape[{pt1_, pt2_}, r_], dVec_] :=
Function[{a, b},
	If[a.dVec > b.dVec, a, b]
][supportPoint[Sphere[pt1, r], dVec], supportPoint[Sphere[pt2, r], dVec]]

(* various cuboid syntax *)
supportPoint[Cuboid[{x1_, y1_, z1_}], dVec_] := supportPoint[Cuboid[{x1, y1, z1}, {x1 + 1, y1 + 1, z1 + 1}], dVec]

supportPoint[Cuboid[{x1_, y1_, z1_}, {x2_, y2_, z2_}], dVec_] :=
	supportPoint[
		{
			{x1, y1, z1}, {x1, y2, z1}, {x2, y1, z1}, {x2, y2, z1},
			{x1, y1, z2}, {x1, y2, z2}, {x2, y1, z2}, {x2, y2, z2}},
		dVec]

(* largest distance between support points *)
supportPoint[obj1Points_, obj2Points_, dVec_] := supportPoint[obj1Points, dVec] - supportPoint[obj2Points, -dVec]

doSimplex

The cases to handle are the 2-, 3-, and 4-simplex cases.

getPerp[v1_, v2_] := Cross[Cross[v1, v2], v1]

doSimplex[{ptB_, ptA_}] := Function[{AB, AO}, {{ptB, ptA}, getPerp[AB, AO]}][ptB - ptA, (*{0,0,0}*) - ptA]

doSimplex[{ptC_, ptB_, ptA_}] :=
Module[{AO, AB, AC, triangleNorm},
	AO = (*{0, 0, 0}*) - ptA;
	AB = ptB - ptA;
	AC = ptC - ptA;
	triangleNorm = Cross[AB, AC];
	If[Dot[Cross[triangleNorm, AC], AO] > 0,
		{{ptC, ptA}, getPerp[AC, AO]}
		,
		If[Dot[Cross[AB, triangleNorm], AO] > 0,
			{{ptB, ptA}, getPerp[AB, AO]}
			,
			If[Dot[triangleNorm, AO] > 0,
				{{ptC, ptB, ptA}, triangleNorm}
				,
				{{ptB, ptC, ptA}, -triangleNorm}]]]]

doSimplex[{ptD_, ptC_, ptB_, ptA_}] :=
Module[{AO, AB, AC, AD, triangleNorm},
	AO = (*{0, 0, 0}*) - ptA;
	AB = ptB - ptA;
	AC = ptC - ptA;
	AD = ptD - ptA;
	triangleNorm = Cross[AB, AC];
	If[Dot[triangleNorm, AO] > 0,
		If[Dot[Cross[AB, triangleNorm], AO] > 0,
			{{ptB, ptA}, getPerp[AB, AO]}
			,
			If[Dot[Cross[triangleNorm, AC], AO] > 0,
				{{ptC, ptA}, getPerp[AC, AO]}
				,
				{{ptC, ptB, ptA}, triangleNorm}]]
		,
		triangleNorm = Cross[AC, AD];
		If[Dot[triangleNorm, AO] > 0,
			If[Dot[Cross[AC, triangleNorm], AO] > 0,
				{{ptC, ptA}, getPerp[AC, AO]}
				,
				If[Dot[Cross[triangleNorm, AD], AO] > 0,
					{{ptD, ptA}, getPerp[AD, AO]}
					,
					{{ptD, ptC, ptA}, triangleNorm}]]
			,
			triangleNorm = Cross[AD, AB];
			If[Dot[triangleNorm, AO] > 0,
				If[Dot[Cross[AD, triangleNorm], AO] > 0,
					{{ptD, ptA}, getPerp[AD, AO]}
					,
					If[Dot[Cross[triangleNorm, AB], AO] > 0,
						{{ptB, ptA}, getPerp[AB, AO]}
						,
						{{ptB, ptD, ptA}, triangleNorm}]]
				,
				Throw[True, "HitQ"]]]]]

Demo: bouncing through an octagon

surfaces=Polygon/@(10*{{{0,1,0},{1,0,0},{1,0,1},{0,1,1}},});

DynamicModule[{r = 2, pt = {2, 2, 10/2}, $TimeFactor = 0.02, vel = 30, dir = {0.94, 0.34, 0}, pausedQ = False},
	Column[{Button["Pause", pausedQ = !pausedQ], #}]& @
	DynamicWrapper[
		Graphics3D[{
			AmbientLight[White], Dynamic[If[impactQ[#, Sphere[pt, r]], {Red, #}, {Green, #}]]& /@ surfaces,
			},
			] // Deploy,
		If[!pausedQ, ]]]

Collision detection: partition the world

For example, Minecraft uses blocks and chunks. This data layer organizes which objects are relevant to the player due to the distance from the player’s position. It saves CPU power in exchange for additional memory storage.

2D graphical explanation

(Bonus) Support functions

Determine block membership

The Ceiling function automatically threads over lists. Note that this conversion is not accurate if the input point is an exact integer at a block boundaries, but this is rare in practice due to numeric precision.

convertCoordinateToBlock[blockSize_Integer, pts_] := Ceiling[pts - blockSize, blockSize]/blockSize

A block is indexed by {i, j, k} ∈ Integers. CoordinateBounds is useful to find the maximum encompassing Cuboid around an object. This is effectively an axis-aligned bounding box.

blockMembers[blockSize_Integer, geometryOrVertices_, neighbors_Integer:0] :=
Module[{spans},
	spans = Range @@@ convertCoordinateToBlock[blockSize, CoordinateBounds[geometryOrVertices]];
	If[neighbors != 0,
		spans = Join[Range[#[[1]] - neighbors, #[[1]] - 1, 1], #, Range[#[[-1]] + 1, #[[-1]] + neighbors, 1]]& /@ spans];
	Flatten[Table[{i, j, k}, {i, spans[[1]]}, {j, spans[[2]]}, {k, spans[[3]]}], 2]]

Calculate the surface normal from polygon vertices

The vertices are assumed to be in clockwise order. If the orientation is reversed then set flipQ to True.

getSurfaceNormal[{v1_, v2_, v3_, ___}, flipQ_:False] := N[If[flipQ, -1, 1]*Normalize[Cross[v1 - v2, v3 - v2]]]

Isolate surface data

The data can be a set of vertices:

isolateSurfacesAndTextures[vertexSets:{{{_, _, _}..}..}, flipQ_:False] :=
<|
	"Surfaces" -> <|MapIndexed[#2[[1]] -> <|"Vertices"-> #1, "Normal" -> getSurfaceNormal[#1, flipQ]|>&, vertexSets]|>,
	"Textures" -> <||>|>

Or the data can be a GraphicsComplex where we must extract every surface instance:

isolateSurfacesAndTextures[gc_GraphicsComplex, flipQ_:False] :=
Module[{textureCounter = 0, surfaces, textures, realVertices},
	textureCounter = 0;
	realVertices = Thread[Range[Length[#]] -> #]&[gc[[1]]];
	surfaces = Reap @
		Cases[
			gc, (* This raw data format is what ResourceFunction["ImportOBJ"][..., "GraphicsComplex"] produces. *)
			{t_Texture, Polygon[verts_, ___, VertexTextureCoordinates -> vtcs_, ___]} :> (
				Sow[++textureCounter -> t];
				MapThread[
					<|
						"Normal" -> getSurfaceNormal[Lookup[realVertices, #1], flipQ],
						"Texture" -> textureCounter,
						"Vertices" -> Lookup[realVertices, #1],
						"VTC" -> #2|>&,
					{verts, vtcs}]),
			Infinity];
	{surfaces, {textures}} = surfaces;
	surfaces = Select[Flatten[surfaces], RegionDimension[Polygon[#Vertices]] == 2&];
	<|
		"Surfaces" -> <|Thread[Range[Length[#]] -> #]&[surfaces]|>,
		"Textures" -> <|textures|>|>]

Create a GraphicsComplex from the surface data

Reverse the $Data into tuples of {_Texture, {__Polygon}}:

convertSurfaceDataToGraphicsComplex[data_Association] :=
Module[{texturePolyPairs, allVertices},
	texturePolyPairs =
		KeyValueMap[
			{data["Textures", #1], Polygon[#2[[1]], VertexTextureCoordinates -> #2[[2]]]}&,
			Transpose[Values[#]]& /@ GroupBy[data["Surfaces"], #Texture& -> ({#Vertices, #VTC}&)]];
	allVertices = Union[Flatten[Cases[texturePolyPairs, Polygon[verts_, ___] :> verts, Infinity], 2]];
	(* The ReplaceAll is safe because we're replacing XYZ coordinates which ignores the UV texture coordinates. *)
	GraphicsComplex[allVertices, ReplaceAll[texturePolyPairs, Thread[# -> Range[Length[#]]]&[allVertices]]]]

For the debug/developer mode we need to tag each surface with ShowContents. It’s conceptually similar to the above case but the second argument of the GraphicsComplex becomes a large Dynamic expression.

convertSurfaceDataToGraphicsComplexTagged[data_Association] :=
Module[{texturePolyPairs, allVertices},
	texturePolyPairs = GroupBy[data["Surfaces"], #Texture& -> (Polygon[#Vertices, VertexTextureCoordinates -> #VTC]&)];
	texturePolyPairs =
		KeyValueMap[
			Function[{tIndex, polySet},
				{
					data["Textures", tIndex],
					KeyValueMap[
						Style[#2, ShowContents -> Hold[!MemberQ[$Data["SurfaceExclusions"], #1]]]&,
						polySet]}],
			texturePolyPairs];
	allVertices = Union[Flatten[Cases[texturePolyPairs, Polygon[verts_, ___] :> verts, Infinity], 1]];
	(* The ReplaceAll is safe because we're replacing XYZ coordinates which ignores the UV texture coordinates. *)
	GraphicsComplex[
		allVertices,
		ReleaseHold[Dynamic[Evaluate[
			ReplaceAll[texturePolyPairs, Thread[# -> Range[Length[#]]]&[allVertices]]]]]]]

makeSurfaceData

groupBlockMembersByIndex[blockSize_, vertexSets_] :=
GroupBy[
	Flatten[MapIndexed[Thread[#2[[1]] -> blockMembers[blockSize, #1]]&, vertexSets]],
	Last -> First]

makeSurfaceData[blockSize_, rawData_, flipQ_:False] :=
Module[{data, vertexSets},
	data = isolateSurfacesAndTextures[rawData, flipQ];
	vertexSets = Values[data[["Surfaces", All, "Vertices"]]];
	<|
		"BlockMembers" -> groupBlockMembersByIndex[blockSize, vertexSets],
		"BlockSize" -> blockSize,
		"SurfaceExclusions" -> {},
		"Surfaces" -> data["Surfaces"],
		"Textures" -> data["Textures"],
		"WorldSize" -> MinMax /@ Transpose[Flatten[vertexSets, 1]]|>]

Data layer

$Data = makeSurfaceData[5,surfaces[[All, 1]]];
Short/@$Data

(Bonus) Determine surface collisions

CoordinateBoundingBox provides an axis-aligned bounding box for the player object.

findSurfaceCollisionIndices[playerObj_] :=
Module[{blocks, indices, vertices},
	(* Which blocks does the player occupy? *)
	blocks = blockMembers[$Data["BlockSize"], CoordinateBoundingBox[playerObj], 1];
	(* Which surfaces (by index) are nearby, and aren't excluded? *)
	indices = DeleteDuplicates[Flatten[Lookup[$Data["BlockMembers"], blocks, {}]]];
	indices = DeleteCases[indices, Alternatives @@ Lookup[$Data, "SurfaceExclusions", {}]];
	(* Of those nearby, which ones impact? *)
	vertices = Lookup[Lookup[$Data["Surfaces"], indices, {}], "Vertices", {}];
	Pick[indices, (impactQ[#1, playerObj]&) /@ vertices]]

Demo: partitioned bouncing through an octagon

DynamicModule[
	{
		r = 2, pt = {2, 2, 10/2}, $TimeFactor = 0.02, vel = 30, dir = {0.94, 0.34, 0}, pausedQ = False,
		blocks, boxes, colors, indices, vertices
	},
	Column[{Button["Pause", pausedQ = !pausedQ], #}]& @
	DynamicWrapper[
		Graphics3D[{, {Opacity[0.01`], Dynamic[boxes]}}, , ViewPoint -> Top],
		If[!pausedQ,
			;
			colors[[indices]] = Red;
			]]]

Getting maps from the internet

The world we’ll use comes from vrchris@Sketchfab (CC4). I’ve edited the original MTL file to not use hard-coded paths and repackaged the data to my GitHub account.

ResourceFunction[“ImportOBJ”]

I developed this function specifically to import textured models, not just the mesh.

zip=URLDownload["https://github.com/KMDaily/WolframExamples/raw/main/Doom_E1M1_World.zip"];
ExtractArchive[zip,FileNameDrop[zip],OverwriteTarget->True];
file=FileNameJoin[{FileNameDrop[zip],"doom_E1M1.obj"}];

gc=ResourceFunction["ImportOBJ"][file,"GraphicsComplex"];

Be wary of the coordinate system

Graphics3D[gc,Axes->True,AxesLabel->{"X","Y","Z"},Method -> {"CacheAllTextures" -> True}]

Rotate to our conventions

start={-1050, 30, -3600};

t=TranslationTransform[{1050,0,3630}].RotationTransform[90 Degree,{1,0,0},start].RotationTransform[180Degree,{0,1,0},start];

gc[[1]]=t[gc[[1]]];

Graphics3D[gc,Axes->True,AxesLabel->{"X","Y","Z"}]

Build the surface data

$Data=makeSurfaceData[50,gc,True];

Collision detection: surface data

({{"Surface Collision", "Steps to Ramps"}, {, }})

(Bonus) Collision and ramp code

resolveSurfaceCollision

Loop over all simultaneously impacting surfaces. Allow for passing through surfaces that face the same direction as the player.

Attributes[resolveSurfaceCollision] = {HoldFirst};

resolveSurfaceCollision[
	(*HELD*) disp_,
	(*FREE*) indices_
] :=
Do[
	Function[normal,
		If[Dot[disp, normal] <= 0, disp = Cross[normal, Cross[disp, normal]]]
	][$Data["Surfaces", i, "Normal"]]
	,
	{i, indices}]

convertStepsToRamps

convertStepsToRamps[stepSize_?NumericQ, indentFractionOfHeight_:1.5] :=
Module[{stepover, height},
	(* Find the vertical surfaces whose height is less than a given size. *)
	stepover = Keys @
		Select[
			$Data["Surfaces"],
			And[
				#[[-1]] - #[[1]]&[MinMax[#Vertices[[All, 3]]]] < stepSize, (* height restriction *)
				#Normal[[3]] == 0  (* vertical wall *)
			]&];
	
	(* Replace the surface data with slopes instead of abrupt steps. *)
	Do[
		height = #[[-1]] - #[[1]]&[MinMax[$Data["Surfaces", i, "Vertices"][[All, 3]]]];
		(* Kick out the bottom edge of the surface in the direction of the surface normal. *)
		$Data["Surfaces", i, "Vertices"] =
			Replace[
				$Data["Surfaces", i, "Vertices"],
				s:{_, _, Min[$Data["Surfaces", i, "Vertices"][[All, 3]]]} :>
					s + indentFractionOfHeight*height*$Data["Surfaces", i, "Normal"],
				1];
		(* Recalculate the surface normal. *)
		$Data["Surfaces", i, "Normal"] = getSurfaceNormal[$Data["Surfaces", i, "Vertices"], True]
	,
	{i, stepover}]]

Update movement function

We no longer have free movement.

Attributes[movement] = {HoldFirst};

movement[
	(*HELD*) {controls_ControllerState, viewVector_},
	(*FREE*) $TimeFactor_, vel_, velRot_, (*NEW*)pObj_Function
] :=
Module[{vv, fmv, tmv, xyAxis, xRot, yRot, disp, aim, pos, indices},
	;
	pos = viewVector[[1]];
	indices = findSurfaceCollisionIndices[pObj[pos + disp]];
	If[indices =!= {}, resolveSurfaceCollision[disp, indices]];
	viewVector = {pos + disp, pos + disp + aim}]

Demo: moving within a polygon environment

convertStepsToRamps[28]

DynamicModule[{$TimeFactor = 0.02, vDisp = 580, vRot = 6, viewVector = {{0, 30, 40}, {0, 31, 40}}},
	DynamicWrapper[
		Graphics3D[{EdgeForm[], gc}, ] // Deploy,
		movement[
			{ControllerState[{"XY1", "XY2"}], viewVector},
			$TimeFactor, vDisp, vRot, (*NEW*)CapsuleShape[{# - {0, 0, 24}, #}, 16]&]]
] // controllerReadyQ

Gravity

Add a downwards acceleration to the player to keep it grounded.

Update movement function

movement[
	(*HELD*) {controls_ControllerState, viewVector_, (*NEW*)vZ_},
	(*FREE*) $TimeFactor_, vel_, velRot_, pObj_Function, (*NEW*)gravity_
] :=
Module[{vv, fmv, tmv, xyAxis, xRot, yRot, disp, aim, pos, indices},
	;
	vZ -= gravity*$TimeFactor;
	disp += {0, 0, vZ*$TimeFactor};
	;
	If[AnyTrue[Lookup[$Data["Surfaces"], indices][[All, "Normal"]], Dot[#, {0, 0, 1}] > 0&], vZ = 0]]

Demo: moving within a polygon environment with gravity

convertStepsToRamps[28]

DynamicModule[
	{
		$TimeFactor = 0.02, vDisp = 580, vRot = 5, viewVector = {{0, 30, 40}, {0, 31, 40}},
		vZ = 0, g = 2000
	},
	DynamicWrapper[
		Graphics3D[{EdgeForm[None], gc}, ] // Deploy,
		movement[
			{ControllerState[{"XY1", "XY2"}], viewVector, (*NEW*)vZ},
			$TimeFactor, vDisp, vRot, CapsuleShape[{# - {0, 0, 24}, #}, 16]&, (*NEW*)g]]
] // controllerReadyQ

Collision detection: line-of-sight

Determining line-of-site is another expensive operation that is made simpler when partitioning the world into blocks.

(Bonus) Super-cover the line-of-sight in an ordered set of world blocks

Demo

blockSize = 300;
makeCuboid[pt_]:=Cuboid[pt blockSize,pt blockSize+blockSize]
worldBounds = 1000* {{-1,1},{-1,1},{-1,1}};

DynamicModule[{$TimeFactor = 0.02, vDisp = 300, vRot = 2, viewVector, ray, vv, cubes = {}, is = Scaled[0.5]},
	viewVector = {{0.1, 0.1, 0.1}, {0.1, 0.1, 0.1} + Normalize[RandomReal[{-1, 1}, 3]]};
	DynamicWrapper[
		EventHandler[
			,
			"MouseUp" :> (is = Scaled[0.5]), PassEventsDown -> True],
		;
		vv = Normalize[viewVector[[2]] - viewVector[[1]]];
		ray = viewVector[[1]] + Min[(MapThread[#1[[-#2]]&, {worldBounds, Sign[vv]}] - viewVector[[1]])/vv]*vv;
		cubes = makeCuboid /@ orderedBlocksAlongLineOfSight[viewVector, blockSize, worldBounds]]
] // controllerReadyQ

Code: orderedBlocksAlongLineOfSight

orderedBlocksAlongLineOfSight[viewVector:{pos_, aim_}, blockSize_, worldBounds_] :=
Module[{vv, directions, originBlock, rayBounds, blockBounds, sets, parameterEndValue, orderedBlockSteps},
	(* Parameterize the ray from the camera position to the edge of the world *)
	vv = Normalize[aim - pos];
	directions = Sign[vv];
	originBlock = convertCoordinateToBlock[blockSize, pos];
	rayBounds = MapThread[#1[[-#2]]&, {worldBounds, directions}];
	blockBounds = convertCoordinateToBlock[blockSize, rayBounds];
	parameterEndValue = Quiet @ Min[Select[(rayBounds - pos)/vv, NumericQ]];
	
	(* Along each coordinate, find the parameter values where the ray crosses the edge of a block *)
	sets = Quiet @
		Replace[(*Note: Range threads over lists *)
			(blockSize*Range[originBlock, blockBounds, directions] - pos)/vv,
			ComplexInfinity -> {},
			1];
	
	(* Label each crossing with a step in that direction, sort by parameter value, and drop the parameters. *)
	orderedBlockSteps =
		Select[
			SortBy[
				Join @@
					MapThread[
						Thread[#1 -> ConstantArray[#2, Length[#1]]]&,
						{sets, {{directions[[1]], 0, 0}, {0, directions[[2]], 0}, {0, 0, directions[[3]]}}}],
				First],
			0 < #[[1]] < parameterEndValue&
		][[All, 2]];
	
	(* Accumulate the block steps starting from the origin block *)
	Accumulate[Prepend[orderedBlockSteps, originBlock]]]

(Bonus) Find the nearest surface

Ultimately we end up with a point-in-polygon problem. This is probably not the fastest approach but it is easy to understand: the point is within the polygon if all of the angles made with each pair of vertices (with the testing point) add up to 2π. The polygons I use have at most 5 vertices.

(* Do the angles between each pair of vertices add up to 2Pi, within an error of 0.001? *)
polyContainsOriginQ[set:{a_, b_, c_}] :=
Apply[(6.2822 < Plus @@ ArcCos[{#1.#2, #2.#3, #3.#1}] < 6.2841&), Normalize /@ set]

polyContainsOriginQ[set:{a_, b_, c_, d_}] :=
Apply[(6.2822 < Plus @@ ArcCos[{#1.#2, #2.#3, #3.#4, #4.#1}] < 6.2841&), Normalize /@ set]

polyContainsOriginQ[set:{a_, b_, c_, d_, e_}] :=
Apply[(6.2822 < Plus @@ ArcCos[{#1.#2, #2.#3, #3.#4, #4.#5, #5.#1}] < 6.2841&), Normalize /@ set]

We calculate the point where the ray intersects the infinite plane that the polygon surface lives within. The distance to this plane is the distance to the polygon surface if-and-only-if the intersection point is within the polygon.

addTemporarySurfaceData[{pos_, aim_}, surfaceData_] :=
Module[{vv, pip, dist, containsOriginQ},
	vv = aim - pos;
	Join[
		surfaceData,
		If[surfaceData["Normal"].vv == 0,
			<|"PointInPlane" -> None, "DistanceToPlane" -> Infinity, "PiercesSurfaceQ" -> False|>
			,
			pip = Function[pos + vv*(#Normal.#Vertices[[1]] - #Normal.pos)/#Normal.vv][surfaceData];
			dist = Dot[vv, pip - pos];
			containsOriginQ = polyContainsOriginQ[surfaceData["Vertices"] - Threaded[pip]];
			<|"PointInPlane" -> pip, "DistanceToPlane" -> dist, "PiercesSurfaceQ" -> containsOriginQ|>]]]

If there are multiple polygons within a given block, then we need to figure out which ones are pierced by the ray, and of those that are pierced, which one is closest to the ray origin.

(* Method:
	Use the ray from the camera position in the aim direction and find where it intersets the surface plane.
	Use this intersection point as the origin and check whether the surface vertices contain it. *)
Attributes[findSurfaceInLineOfSight] = {HoldFirst};
	
findSurfaceInLineOfSight[
	(*HELD*) $Data_,
	(*FREE*) viewVector_, orderedBlocksAlongLineOfSight_
] :=
Module[{order, localData, i, currentSet, temp},
	order = Lookup[$Data["BlockMembers"], orderedBlocksAlongLineOfSight, Nothing];
	order = Replace[DeleteCases[order, Alternatives @@ Lookup[$Data, "SurfaceExclusions", {}], 2], {} -> Nothing, 1];
	If[order === {}, Return[{0, {0, 0, 0}, Infinity}]];
	localData = <||>;
	
	(* Loop over the ordered blocks, stopping when we find the surface we're facing *)
	i = 1;
	While[i <= Length[order],
		currentSet = <|
			Table[
				Lookup[(* Use Lookup to add data to surfaces we have yet to check. *)
					localData,
					j,
					j -> addTemporarySurfaceData[viewVector, $Data["Surfaces", j]],
					j -> #&],
				{j, order[[i]]}]|>;
		temp = Select[currentSet, #DistanceToPlane > 0 && #PiercesSurfaceQ&];
		(* Either exit loop or memoize the surfaces so we don't repeat expensive calculations in another Lookup step. *)
		If[temp =!= <||>, Break[], localData = Join[localData, currentSet]];
		i++];
	
	If[temp === <||>,
		{0, {0, 0, 0}, Infinity}
		,
		First @ KeyValueMap[{#1, #2["PointInPlane"], #2["DistanceToPlane"]}&, SortBy[temp, #DistanceToPlane&]]]
]

(* Method Alternative (slightly slower but easier to understand code):
	Same as above but without memoization. Also brute-force calculate the data along the entire view vector. *)
findSurfaceInLineOfSightAlt[
	(*HELD*) $Data_,
	(*FREE*) viewVector_, orderedBlocksAlongLineOfSight_
] :=
Module[{order},
	order = DeleteDuplicates[Flatten[Lookup[$Data["BlockMembers"], orderedBlocksAlongLineOfSight, Nothing]]];
	
	{#Index, #PointInPlane, #DistanceToPlane}&[
		First[
			SortBy[
				Select[
					MapThread[
						<|"Index" -> #1, addTemporarySurfaceData[viewVector, #2]|>&,
						{order, Lookup[$Data["Surfaces"], order]}],
					#DistanceToPlane > 0 && #PiercesSurfaceQ&],
				#DistanceToPlane&],
			<|"Index" -> 0, "PointInPlane" -> {0, 0, 0}, "DistanceToPlane" -> Infinity|>]]]

Demo: highlight surfaces

DynamicModule[
	{
		$TimeFactor = 0.02, vDisp = 580, vRot = 6, viewVector = {{0, 30, 40}, {0, 31, 40}},
		vZ = 0, g = 2000, index, highlight, pip, dist
	},
	 @
	Overlay[{#, "⊕"}, Alignment -> {Center, Center}]& @
	DynamicWrapper[
		 // Deploy,
		;
		{index, pip, dist} =
			findSurfaceInLineOfSight[
				$Data,
				viewVector, orderedBlocksAlongLineOfSight[viewVector, $Data["BlockSize"], $Data["WorldSize"]]];
		highlight = Polygon[(#Vertices + Threaded[#Normal])&[$Data["Surfaces", index]]]]
] // controllerReadyQ

Collision detection: line-of-sight interactions

Make billboard targets

Make a set of Cylinder primitives. The cylinders will be used for hit-detection while we draw billboards in the game world.

targetOrigins={{-228,175,0},};

$Targets=<|
"BlockMembers"->
groupBlockMembersByIndex[$Data["BlockSize"],Cylinder[{#,#+{0,0,60}},15]&/@targetOrigins],
"Primitives"-><|MapIndexed[#2[[1]]-><|
"Spec"->Cylinder[{#1,#1+{0,0,60}},15],
"Origin"->#1|>&,targetOrigins]|>,
"PrimitiveExclusions"->{}|>;

target=;

(Bonus) Find the nearest primitive

I’ve only implemented Cylinder but this should be extensible to other primitives by overloading the intersectionPoints function.

intersectionPoints

See this explanation on gamedev.stackexchange.com. The approach first shifts the origin to the center of the cylinder. The cylinder’s axis is used as a coordinate axis so many of the calculations involve projections along this axis and in other vector operations.

intersectionPoints[{pos_, aim_}, Cylinder[{base_, top_}]] :=
	intersectionPoints[{pos, aim}, Cylinder[{base, top}, 1]]

intersectionPoints[{pos_, aim_}, Cylinder[{base_, top_}, r_]] :=
Module[{dir, uN, h, ccO, ccR, rN, dN, a, b, c, discriminant, t, rayOriginBetweenEndCapsQ, pts},
	dir = Normalize[aim - pos];   (* ray direction *)
	h = Norm[top - base];         (* length of cylinder *)
	uN = (top - base)/h;          (* unit-length direction of cylinder from base to top *)
	ccO = base + uN*h*0.5;        (* origin of cylinder coordinate system *)
	ccR = pos - ccO;              (* ray origin in cylinder coordinate system *)
	rN = uN.ccR;                  (* component of ray origin along cylinder axis *)
	dN = uN.dir;                  (* component of ray direction along cylinder axis *)
	
	c = ccR.ccR - rN*rN - r*r; (* "c" in quadratic formula, difference of squared radii *)
	
	(* Case 0: exit early if ray starts within cylinder *)
	rayOriginBetweenEndCapsQ = -h*0.5 <= rN <= h*0.5;
	If[c <= 0 && rayOriginBetweenEndCapsQ, Return[{}]];
	
	(* Case 1A: exit early if ray points away from cylinder *)
	If[!rayOriginBetweenEndCapsQ && rN*dN > 0, Return[{}]];
	
	(* Case 1B: check end caps *)
	t = If[dN == 0, {}, ({1, -1}*h*0.5 - rN)/dN]; (* along cylinder axis, find parameter value at end planes*)
	pts = Select[ccR + dir*#& /@ t, #.# - 0.25*h*h - r*r <= 0&]; (* accept points within radius length *)
	If[Length[pts] == 2, Return[pts + Threaded[ccO]]]; (* return if we pass through both caps *)
	
	(* Case 2: check sides
		1. project cylinder to a disk on plane of ray's origin
		2. use a new ray from projected disk center to a point along the projected ray
		3. solve quadratic at the point where the new ray's squared length is r^2 *)
	a = 1 - dN*dN;
	b = 2*ccR.dir - 2*dN*rN;
	discriminant = b*b - 4*a*c;
	If[discriminant >= 0,
		t = (-b + {1, -1}*(Sqrt[discriminant]))/(2*a)
		,
		Return[If[Length[pts] == 0, {}, pts + Threaded[ccO]]]];
	pts = Join[pts, Select[ccR + dir*#& /@ t, Abs[uN.#] < 0.5*h&]];
	If[pts === {}, {}, pts + Threaded[ccO]] (* put points back into global coordinate system *)
]

findPrimitiveInLineOfSight

This is almost identical to findSurfaceInLineOfSight but it applies to any primitive, so long as an appropriate version of intersectionPoints exists for that primitive. It uses memoization to avoid duplicating expensive calculations.

(* Use the ray from the camera position in the aim direction and find where it intersets the primitive object. *)
Attributes[findPrimitiveInLineOfSight] = {HoldFirst};
	
findPrimitiveInLineOfSight[
	(*HELD*) $Data_,
	(*FREE*) viewVector_, orderedBlocksAlongLineOfSight_
] :=
Module[{order, localData, i, currentSet, temp},
	order = Lookup[$Data["BlockMembers"], orderedBlocksAlongLineOfSight, Nothing];
	order = Replace[DeleteCases[order, Alternatives @@ Lookup[$Data, "PrimitiveExclusions", {}], 2], {} -> Nothing, 1];
	If[order === {}, Return[{0, {0, 0, 0}, Infinity}]];
	localData = <||>;
	
	(* Loop over the ordered blocks, stopping when we find the surface we're facing *)
	i = 1;
	While[i <= Length[order],
		currentSet = <|
			Table[
				Lookup[(* Use Lookup to add data to surfaces we have yet to check. *)
					localData,
					j,
					j -> SortBy[
							<|
								"Point" -> #,
								"Distance" -> (Norm[# - viewVector[[1]]])
							|>& /@ intersectionPoints[viewVector, $Data["Primitives", j, "Spec"]],
							#Distance&],
					j -> #&],
				{j, order[[i]]}]|>;
		(* Either exit loop or memoize the distance so we don't repeat expensive calculations in another Lookup step. *)
		temp = Select[currentSet, # =!= {}&]; (* exclude those that don't intersect *)
		If[temp =!= <||>, Break[], localData = Join[localData, currentSet]];
		i++];
	
	(* output: {primitive index, nearest intersection point, distance to primitive}*)
	If[temp === <||>,
		{0, {0, 0, 0}, Infinity}
		,
		First @ KeyValueMap[{#1, First[#2]["Point"], First[#2]["Distance"]}&, temp]]
]

(Bonus) Silly sounds

Pew Pew Two by OBXJohn | License: Creative Commons 0; modified to take only the first “pew”

pew=;

typerwriter_ding.wav by LeonelAle71 | License: Creative Commons 0

ding=;

Soothing Waterdrop Click.wav by MATRIXXX_ | License: Creative Commons 0

bloop=;

Movement: output the player’s angle and add a new button

movement[
	(*HELD*) {controls_ControllerState, viewVector_, vZ_, (*NEW*)angle_, canPressX_, ammo_},
	(*FREE*) $TimeFactor_, vel_, velRot_, pObj_Function, gravity_
] :=
Module[
	{
		vv, fmv, tmv, xyAxis, xRot, yRot, disp, aim, pos, indices,
		(*NEW*)xButton, los, sIndex, sPIP, sDist, tIndex, tPIP, tDist
	},
	{xyAxis, {xRot, yRot}, xButton} = noDrift[controls];
	;
	angle = π/2 + ArcTan[fmv[[1]], fmv[[2]]];
	If[xButton,
		If[canPressX && ammo >= 0, (* Prevents the button action from continually firing. *)
			canPressX = False;
			AudioPlay[pew]; ammo -= 1;
			los = orderedBlocksAlongLineOfSight[viewVector, $Data["BlockSize"], $Data["WorldSize"]];
			{sIndex, sPIP, sDist} = findSurfaceInLineOfSight[$Data, viewVector, los];
			{tIndex, tPIP, tDist} = findPrimitiveInLineOfSight[$Targets, viewVector, los];
			If[tDist < sDist, AudioPlay[ding]; AppendTo[$Targets["PrimitiveExclusions"], tIndex]]]
		,
		canPressX = True]
]

(Bonus) Make target copies

makeTargetCopies[] :=
If[# === {},
	TranslationTransform[{0, 0, -100}] (* hide a copy of the target below the visible area *)
	,
	TranslationTransform /@ #
]&[Lookup[Values[KeyDrop[$Targets["Primitives"], $Targets["PrimitiveExclusions"]]], "Origin", {}]]

Demo: target practice

DynamicModule[
	{
		$TimeFactor = 0.02, vDisp = 580, vRot = 6, viewVector = {{0, 30, 40}, {0, 31, 40}}, angle = 0,
		vv, vZ = 0, g = 2000, canPressX = True, targetCopies, ammo = 30
	},
	Overlay[{#, "⊕"}, Alignment -> {Center, Center}]& @
	DynamicWrapper[
		Graphics3D[{,
			Dynamic @
			GeometricTransformation[
				GeometricTransformation[
					target,
					{{{Cos[angle], -Sin[angle], 0}, {Sin[angle], Cos[angle], 0}, {0, 0, 1}}, {0, 0, 0}}],
				targetCopies]},
			] // Deploy,
		; targetCopies = makeTargetCopies[];]
] // controllerReadyQ

Heads-up display (HUD)

Create an Overlay to display useful information. This uses Haloing (13.3) to highlight the numeric characters.

(Bonus) makeHUD

style1[label_] := Style[label, FontColor -> GrayLevel[0.71], FontSize -> Scaled[0.03]]
style2[label_] := Style[label, FontColor -> GrayLevel[0.71], FontSize -> Scaled[0.02]]
style3[label_] := Style[label, FontColor -> , FontSize -> Scaled[0.065], FontWeight -> Bold]
style4[label_] := Style[label, FontColor -> RGBColor["#FFFF73"], FontSize -> Scaled[0.02], FontWeight -> Bold]

text1[label_, x_] :=       Text[style1[label], {  x, 0}, { Left, Bottom}]
text2[label_, y_] :=       Text[style2[label], {255, y}, { Left, Bottom}]
text3[label_, {x_, y_}] := Text[style3[label], {  x, y}, {Right, Bottom}]
text4[label_, y_] :=       Text[style4[label], {287, y}, {Right, Bottom}]
text5[label_, y_] :=       Text[style4[label], {313, y}, {Right, Bottom}]

line[y_] := Line[{{293, y}, {298, y + 5}}]

Attributes[makeHUD] = {HoldAll};
makeHUD[imageSize_, ammo_, health_, armor_, bullets_, shells_, rockets_, cells_, face_] :=
Graphics[
	{
		{EdgeForm[None], FaceForm[GrayLevel[0.31]], Rectangle[{0, 0}, {320, 32}]},
		FaceForm[GrayLevel[27/255.]], EdgeForm[GrayLevel[131/255.]],
		Rectangle[{47, 0}, {49, 32}], Rectangle[{104, 0}, {106, 32}], Rectangle[{143, 0}, {179, 32}],
		Rectangle[{236, 0}, {250, 32}],
		FaceForm[None],
		Rectangle[{107.5, 22}, {117.5, 30}], Rectangle[{119.5, 22}, {129.5, 30}], Rectangle[{131.5, 22}, {141.5, 30}],
		Rectangle[{107.5, 12}, {117.5, 20}], Rectangle[{119.5, 12}, {129.5, 20}], Rectangle[{131.5, 12}, {141.5, 20}],
		FaceForm[GrayLevel[0.31]],
		Rectangle[{237, 21.5}, {249, 30.5}], Rectangle[{237, 11.5}, {249, 20.5}], Rectangle[{237, 1.5}, {249, 10.5}],
		GrayLevel[0.71],
		line[25], line[18], line[11], line[4],
		text1["AMMO", 9], text1["HEALTH", 56], text1["ARMS", 111], text1["ARMOR", 189],
		text2["BULL", 23], text2["SHEL", 16], text2["RCKT", 9], text2["CELL", 2],
		Haloing[RGBColor["#430000"]],
		text3[Dynamic[ammo], {46, 8}], 
		text3[Dynamic[Row[{health, "%"}]], {103, 8}], text3[Dynamic[Row[{armor, "%"}]], {235, 8}],
		Haloing[None],
		text4[Dynamic[bullets], 23], text4[Dynamic[shells], 16], text4[Dynamic[rockets], 9], text4[Dynamic[cells], 2],
		text5["200", 23], text5["50", 16], text5["50", 9], text5["300", 2],
		Raster[
			Dynamic[If[face, Reverse @ ImageData[], Reverse @ ImageData[]]],
			{{145, 2}, {176, 30}}]},
	ImageSize -> imageSize, PlotRangePadding -> 0]

HUD

Manipulate[
	makeHUD[Scaled[0.5], ammo, health, armor, bullets, shells, rockets, cells, face],
	{{ammo, 50}, 0, 50, 1}, {{health, 50}, 0, 50, 1}, {{armor, 50}, 0, 50, 1}, {{bullets, 50}, 0, 50, 1},
	{{shells, 50}, 0, 50, 1}, {{rockets, 50}, 0, 50, 1}, {{cells, 50}, 0, 50, 1}, {face, {True, False}}]

Make items

Replace some of the targets we had earlier with spheres that will act as objects that we can collect.

health={{-315,93,0},};  armor={{-621,600,-8},};

$Items=<|"BlockMembers"->groupBlockMembersByIndex[$Data["BlockSize"],Sphere[# + {0, 0, 15},15]&/@Join[health,armor]],"Primitives"-><|MapIndexed[#2[[1]]-><|
"Spec"->Sphere[#1 + {0, 0, 15},15],
"Origin"->#1,
 "Type" -> If[#2[[1]] <=Length[health], "Health", "Armor"]|>&,Join[health,armor]]|>,"PrimitiveExclusions"->{}|>;

(Bonus) Make item copies and collect items

makeItemCopies[type_String] :=
If[# === {},
	TranslationTransform[{0, 0, -100}] (* hide a copy of the item below the visible area *)
	,
	TranslationTransform /@ #
]&[
	Lookup[
		Values[KeyDrop[Select[$Items["Primitives"], #Type === type&], $Items["PrimitiveExclusions"]]],
		"Origin",
		{}]]

Attributes[collectItems] = {HoldFirst};

collectItems[
	(*HELD*) {face_, health_, armor_, currentPos_},
	(*FREE*) pos_, dist_
] :=
Module[{nearbyItems},
	nearbyItems = Lookup[$Items["BlockMembers"], blockMembers[$Data["BlockSize"], pos, 1], Nothing];
	If[nearbyItems === {}, Return[]];
	nearbyItems = KeyTake[$Items["Primitives"], Union[Flatten[nearbyItems]]];
	nearbyItems = Select[nearbyItems, Norm[pos - #Origin] <= dist&];
	KeyValueMap[
		If[!MemberQ[$Items["PrimitiveExclusions"], #1],
			AppendTo[$Items["PrimitiveExclusions"], #1];
			Switch[#2["Type"],
				"Health", health += 2; face = True; AudioPlay[bloop]; currentPos = pos,
				"Armor",   armor += 2; face = True; AudioPlay[bloop]; currentPos = pos]]&
		,
		nearbyItems]
]

Demo: collecting items

targetOrigins2=Complement[targetOrigins,health,armor];
$Targets=;

DynamicModule[
	{
		$TimeFactor = 0.02, vDisp = 580, vRot = 6, viewVector = {{0, 30, 40}, {0, 31, 40}}, angle = 0,
		vZ = 0, g = 2000, canPressX = True, targetCopies, ammo = 30, health = 50, armor = 0, pos,
		bullets = 30, shells = 0, rockets = 0, cells = 0, face = False, armorCopies, healthCopies
	},
	Overlay[
		{#, Dynamic[makeHUD[Scaled[0.4], ammo, health, armor, bullets, shells, rockets, cells, face]]},
		Alignment -> {Center, Bottom}]& @
	Overlay[{#, "⊕"}, Alignment -> {Center, Center}]& @
	DynamicWrapper[
		Graphics3D[{, ,
			Dynamic[GeometricTransformation[{Green, Sphere[{0, 0, 15}, 15]}, armorCopies]],
			Dynamic[GeometricTransformation[{Blue, Sphere[{0, 0, 15}, 15]}, healthCopies]]},
			] // Deploy,
		; targetCopies = makeTargetCopies[];
		collectItems[{face, health, armor, pos}, viewVector[[1]], 60];
		armorCopies = makeItemCopies["Armor"]; healthCopies = makeItemCopies["Health"];
		If[Norm[viewVector[[1]] - pos] > 40, face = False];
	]
] // controllerReadyQ

Citations

Geometry

Doom E1M1 map by vrchris at SketchFab | License: Creative Commons 4

Sounds

Pew Pew Two by OBXJohn | License: Creative Commons 0

typerwriter_ding.wav by LeonelAle71 | License: Creative Commons 0

Soothing Waterdrop Click.wav by MATRIXXX_ | License: Creative Commons 0

Further Reading

Wolfram Community

Understanding Graphics3D's view options: the intuitive way by Silvia Hao

Glam-ifying 3D graphics by Anika Patel

Video Game Physics Tutorial by Nilson Souto

Gilbert-Johnson-Keerthi algorithm

Wikipedia page

Reducible video

GameDev.StackExchange

Ray-cylinder intersection test

Supercover (grid-traversal algorithms e.g. Bresenham's)

(Bonus) Code variations

Different version of resolveSurfaceCollision

Note: that this version of resolveSurfaceCollision has more arguments as it allows the player’s vertical position to automatically (and rather jarringly) increase in order to step over walls of a given stepSize.

bottomPosition: the z-coordinate location of the bottom of the player object

stepSize: the maximum height of a step that the player can get over

Attributes[resolveSurfaceCollision] = {HoldFirst};

resolveSurfaceCollision[
	(*HELD*) disp_,
	(*FREE*) bottomPosition_, indices_, stepSize_
] :=
Module[{vertices, normal, min, max},
	Do[
		vertices = $Data["Surfaces", i, "Vertices"];
		normal = $Data["Surfaces", i, "Normal"];
		Which[
			(* Pass through surfaces that point in the same direction as the player movement. *)
			Dot[disp, normal] > 0,
				Null,
			(* IF NOT USING RAMPS: vertical surface, if small enough, can be stepped over *)
			Dot[normal, {0, 0, 1}] == 0,
				{min, max} = MinMax[vertices[[All, 3]]];
				If[min - 0.1stepSize <= bottomPosition < max && max - min < stepSize,
					disp[[3]] += max - bottomPosition
					,
					disp = Cross[normal, Cross[disp, normal]]],
			(* sloped surface *)
			True,
				disp = Cross[normal, Cross[disp, normal]]]
		,
		{i, indices}]]

Jumping using a button

Note: this movement function assumes the player automatically steps over a minimum step size and is intended to work with the above resolveSurfaceCollision function.

pBottom: a function that calculates the player object’s minimum z-coordinate

stepSize: the maximum height of a step that the player can get over

impulse: the initial vertical velocity due to pressing the jump button

buttonEnabledQ: boolean that prevents continuous jumping by holding down the jump button

movement[
	(*HELD*) {controls_ControllerState, viewVector_, vZ_, inAirQ_, (*NEW*)buttonEnabledQ_},
	(*FREE*) $TimeFactor_, vel_, velRot_, pObj_Function, pBottom_Function, stepSize_, gravity_, (*NEW*)impulse_
] :=
Module[{vv, fmv, tmv, xyAxis, xRot, yRot, disp, aim, pos, indices, (*NEW*)buttonA},
	{xyAxis, {xRot, yRot}, (*NEW*)buttonA} = noDrift[controls];
	;
	If[buttonA,
		If[buttonEnabledQ && !inAirQ, vZ = impulse; buttonEnabledQ = False; inAirQ = True]
		, (* else button has been released so restore its action *)
		buttonEnabledQ = True];
	;
	(* SURFACE COLLISION CALCULATIONS: uses more complicated resolveSurfaceCollision *)
	pos = viewVector[[1]];
	indices = findSurfaceCollisionIndices[pObj[pos + disp]];
	If[indices =!= {}, resolveSurfaceCollision[disp, pBottom[pos + disp], indices, stepSize]];
	viewVector = {pos + disp, pos + disp + aim};
	(* ============================== *)
	]

(Bonus) Tool: developer mode

Let’s build a tool to interactively set $Logic data about the world. The effect of pressing button “X” changes depending on which interface is active.

Items: add health or armor bonus locations on the ground (indicated by blue and green disks)

Doors: indicate which surfaces should move when interacted with

the list of surfaces within the door logic are removed from collision detection and not drawn

doors can be set to be opened via a switch

Switches: indicate which surfaces act as switches

Enemies: add enemy positions on the ground (red disks)

(Bonus) Code: surfacePropertySetter, …

SetAttributes[{doorInterface, itemInterface, switchInterface, enemyInterface, surfacePropertySetter}, HoldAll]

surfacePropertySetter[index_, pip_, logicType_, activeDoor_, activeSwitch_, itemType_, enemyType_] :=
DynamicModule[{canPressX = True},
	TabView[
		{
			{"Items", "Items" -> itemInterface[itemType]},
			{"Doors", "Doors" -> doorInterface[activeDoor]},
			{"Switches", "Switches" -> switchInterface[activeSwitch]},
			{"Enemies", "Enemies" -> enemyInterface[enemyType]}},
		Dynamic[logicType],
		ControlPlacement -> Left,
		LabelStyle -> {Bold}],
	Initialization :> ($Logic = <|"Switches" -> <||>, "Doors" -> <||>, "Items" -> <||>, "Enemies" -> <||>|>)]

doorInterface[activeDoor_] :=
DynamicModule[{nDoors = 0},
	Column[{
		Button["Add Door",
			nDoors++;
			AssociateTo[
				$Logic["Doors"],
				nDoors -> <|
					Replace[
						ToExpression["Game`Private`Door" <> ToString[nDoors], StandardForm, Hold],
						Hold[x_] :> ("Variable" :> x)],
					"MoveDistance" -> 72,
					"MoveSpeed" -> 1,
					"SurfaceIndices" -> {},
					"Switch" -> None|>],
			ImageSize -> Automatic],
		"",
		Style["Active Door:", Bold],
		Dynamic[If[# === {}, None, SetterBar[Dynamic[activeDoor], #]]&[Keys[Lookup[$Logic, "Doors", {}]]]],
		"",
		Style["Door Properties:", Bold],
		PaneSelector[
			{
				True ->
					Grid[
						{
							{"Move Distance", InputField[Dynamic[$Logic["Doors", activeDoor, "MoveDistance"]], Number]},
							{"Move Speed", InputField[Dynamic[$Logic["Doors", activeDoor, "MoveSpeed"]], Number]},
							{"Surfaces", Dynamic @
								CheckboxBar[
									Dynamic[$Data["SurfaceExclusions"]],
									$Logic["Doors", activeDoor, "SurfaceIndices"],
									Appearance -> "Vertical", Method -> "Active"]},
							{"Switch", Dynamic @
								SetterBar[
									Dynamic[$Logic["Doors", activeDoor, "Switch"]],
									Keys[Lookup[$Logic, "Switches", {None -> None}, Prepend[#, None -> None]&]]]}},
						Alignment -> {{Right, Left}}],
				False -> "No active door"},
			Dynamic[nDoors > 0],
			ImageSize -> Automatic]}]]

switchInterface[activeSwitch_] :=
DynamicModule[{nSwitches = 0, activeOperationType = "Door"},
	Column[{
		Button["Add Switch",
			nSwitches++;
			AssociateTo[
				$Logic["Switches"],
				nSwitches -> <|
					"ActivatedQ" -> False,
					"SurfaceIndices" -> {},
					"OperationType" -> "Door",
					"OperationIndex" -> None|>],
			ImageSize -> Automatic],
		"",
		Style["Active Switch:", Bold],
		Dynamic[If[# === {}, None, SetterBar[Dynamic[activeSwitch], #]]&[Keys[Lookup[$Logic, "Switches", {}]]]],
		"",
		Style["Switch Properties:", Bold],
		PaneSelector[
			{
				True ->
					Grid[{{"Surfaces", Dynamic[$Logic["Switches", activeSwitch, "SurfaceIndices"]]}}],
				False -> "No active switch"},
			Dynamic[nSwitches > 0],
			ImageSize -> Automatic]}]]

itemInterface[itemType_] :=
DynamicModule[{},
	Column[{
		"Create item at current position",
		SetterBar[Dynamic[itemType], {"ArmorBonus", "HealthBonus"}]}],
	Initialization :> (
		$Logic["Items"] = <|
			"ArmorBonus" -> <|"Positions" -> {}|>,
			"HealthBonus" -> <|"Positions" -> {}|>|>)]

enemyInterface[enemyType_] :=
DynamicModule[{},
	Column[{
		"Create enemy at current position",
		SetterBar[Dynamic[enemyType], {"ShotgunGuy"}]}],
	Initialization :> (
		$Logic["Enemies"] = <|
			"ShotgunGuy" -> <|"Positions" -> {}|>|>)]

updateProperties[index_, pip_, "Doors", activeDoor_Integer, _, _, _] := (
$Logic["Doors", activeDoor, "SurfaceIndices"] =
	If[MemberQ[#, index],
		DeleteCases[#, index]
		,
		Append[#, index]	
	]&[$Logic["Doors", activeDoor, "SurfaceIndices"]];
AppendTo[$Data["SurfaceExclusions"], index])

updateProperties[index_, pip_, "Switches", _, activeSwitch_Integer, _, _] :=
$Logic["Switches", activeSwitch, "SurfaceIndices"] =
	If[MemberQ[#, index],
		DeleteCases[#, index]
		,
		Append[#, index]
	]&[$Logic["Switches", activeSwitch, "SurfaceIndices"]]

updateProperties[index_, pip_, "Items", _, _, itemType_String, _] :=
$Logic["Items", itemType, "Positions"] =
	If[AnyTrue[#, Norm[pip - #] < 15&],
		Select[#, Norm[pip - #] >= 15&]
		,
		If[$Data["Surfaces", index, "Normal"] == {0.,0.,1.}, Append[#, Round[pip]], #]
	]&[$Logic["Items", itemType, "Positions"]]

updateProperties[index_, pip_, "Enemies", _, _, _, enemyType_String] :=
$Logic["Enemies", enemyType, "Positions"] =
	If[AnyTrue[#, Norm[pip - #] < 15&],
		Select[#, Norm[pip - #] >= 15&]
		,
		If[$Data["Surfaces", index, "Normal"] == {0.,0.,1.}, Append[#, Round[pip]], #]
	]&[$Logic["Enemies", enemyType, "Positions"]]

Demo

gc2=convertSurfaceDataToGraphicsComplexTagged[AssociateTo[$Data, "SurfaceExclusions"->{}]];

DynamicModule[{pip, index, logicType, activeDoor, activeSwitch, itemType, enemyType, armor, health, guy},
	Grid[{{
		DynamicModule[
			{
				$TimeFactor = 0.01, vDisp = 580, vRot = 5, viewVector = {{0, 30, 40}, {0, 31, 40}},
				vZ = 0, g = 2000, canPressX = True, dist
			},
			Overlay[{#, "⊕"}, Alignment -> {Center, Center}]& @
			DynamicWrapper[
				,
				;
				{index, pip, dist} = ;
				If[ControllerState["X Button"],
					If[canPressX,
						canPressX = False;
						updateProperties[index, pip, logicType, activeDoor, activeSwitch, itemType, enemyType]]
					,
					canPressX = True];
				armor = If[# === {}, {}, # + Threaded[{0, 0, 2}]]&[$Logic["Items", "ArmorBonus", "Positions"]];
				health = If[# === {}, {}, # + Threaded[{0, 0, 2}]]&[$Logic["Items", "HealthBonus", "Positions"]];
				guy = If[# === {}, {}, # + Threaded[{0, 0, 2}]]&[$Logic["Enemies", "ShotgunGuy", "Positions"]];
			]
		],
	surfacePropertySetter[index, pip, logicType, activeDoor, activeSwitch, itemType, enemyType]}}]
] // Deploy // controllerReadyQ