Source
module FirstPerson exposing (main)
-- Walk around in 3D space using the keyboard.
--
-- Dependencies:
-- elm install elm-explorations/linear-algebra
-- elm install elm-explorations/webgl
--
-- Try adding the ability to crouch or to land on top of the crate!
--
import Browser
import Browser.Dom as Dom
import Browser.Events as E
import Html exposing (Html, p, text, div)
import Html.Attributes exposing (width, height, style)
import Json.Decode as D
import Math.Matrix4 as Mat4 exposing (Mat4)
import Math.Vector2 as Vec2 exposing (Vec2, vec2)
import Math.Vector3 as Vec3 exposing (Vec3, vec3)
import Task
import WebGL
import WebGL.Texture as Texture
-- MAIN
main : Program () Model Msg
main =
Browser.element
{ init = init
, view = view
, update = \msg model -> (update msg model, Cmd.none)
, subscriptions = subscriptions
}
-- MODEL
type alias Model =
{ keys : Keys
, width : Float
, height : Float
, person : Person
, texture : Maybe Texture.Texture
}
type alias Keys =
{ up : Bool
, left : Bool
, down : Bool
, right : Bool
, space : Bool
}
type alias Person =
{ position : Vec3
, velocity : Vec3
}
init : () -> ( Model, Cmd Msg )
init _ =
( { keys = noKeys
, width = 400
, height = 400
, person = Person (vec3 0 eyeLevel -10) (vec3 0 0 0)
, texture = Nothing
}
, Cmd.batch
[ Task.attempt GotTexture (Texture.load "https://elm-lang.org/images/wood-crate.jpg")
, Task.perform (\{viewport} -> Resized viewport.width viewport.height) Dom.getViewport
]
)
eyeLevel : Float
eyeLevel =
2
noKeys : Keys
noKeys =
Keys False False False False False
-- UPDATE
type Msg
= GotTexture (Result Texture.Error Texture.Texture)
| KeyChanged Bool String
| TimeDelta Float
| Resized Float Float
| VisibilityChanged E.Visibility
update : Msg -> Model -> Model
update msg model =
case msg of
GotTexture result ->
{ model | texture = Result.toMaybe result }
KeyChanged isDown key ->
{ model | keys = updateKeys isDown key model.keys }
TimeDelta dt ->
{ model | person = updatePerson dt model.keys model.person }
Resized width height ->
{ model
| width = width
, height = height
}
VisibilityChanged _ ->
{ model | keys = noKeys }
updateKeys : Bool -> String -> Keys -> Keys
updateKeys isDown key keys =
case key of
" " -> { keys | space = isDown }
"ArrowUp" -> { keys | up = isDown }
"ArrowLeft" -> { keys | left = isDown }
"ArrowDown" -> { keys | down = isDown }
"ArrowRight" -> { keys | right = isDown }
_ -> keys
updatePerson : Float -> Keys -> Person -> Person
updatePerson dt keys person =
let
velocity = stepVelocity dt keys person
position = Vec3.add person.position (Vec3.scale (dt / 500) velocity)
in
if Vec3.getY position < eyeLevel then
{ position = Vec3.setY eyeLevel position
, velocity = Vec3.setY 0 velocity
}
else
{ position = position
, velocity = velocity
}
stepVelocity : Float -> Keys -> Person -> Vec3
stepVelocity dt { left, right, up, down, space } person =
if Vec3.getY person.position > eyeLevel then
Vec3.setY (Vec3.getY person.velocity - dt / 250) person.velocity
else
let
toV positive negative =
(if positive then 1 else 0) - (if negative then 1 else 0)
in
vec3 (toV left right) (if space then 2 else 0) (toV up down)
-- SUBSCRIPTIONS
subscriptions : Model -> Sub Msg
subscriptions model =
Sub.batch
[ E.onResize (\w h -> Resized (toFloat w) (toFloat h))
, E.onKeyUp (D.map (KeyChanged False) (D.field "key" D.string))
, E.onKeyDown (D.map (KeyChanged True) (D.field "key" D.string))
, E.onAnimationFrameDelta TimeDelta
, E.onVisibilityChange VisibilityChanged
]
-- VIEW
view : Model -> Html Msg
view model =
let
entities =
case model.texture of
Nothing ->
[]
Just texture ->
[ viewCrate model.width model.height model.person texture ]
in
div
[ style "position" "absolute"
, style "left" "0"
, style "top" "0"
, style "width" (String.fromFloat model.width ++ "px")
, style "height" (String.fromFloat model.height ++ "px")
]
[ WebGL.toHtmlWith [ WebGL.depth 1, WebGL.clearColor 1 1 1 1 ]
[ style "display" "block"
, width (round model.width)
, height (round model.height)
]
entities
, keyboardInstructions model.keys
]
viewCrate : Float -> Float -> Person -> Texture.Texture -> WebGL.Entity
viewCrate width height person texture =
let
perspective =
Mat4.mul
(Mat4.makePerspective 45 (width / height) 0.01 100)
(Mat4.makeLookAt person.position (Vec3.add person.position Vec3.k) Vec3.j)
in
WebGL.entity vertexShader fragmentShader crate
{ texture = texture
, perspective = perspective
}
keyboardInstructions : Keys -> Html msg
keyboardInstructions keys =
div
[ style "position" "absolute"
, style "font-family" "monospace"
, style "text-align" "center"
, style "left" "20px"
, style "right" "20px"
, style "top" "20px"
]
[ p [] [ text "Walk around with a first person perspective." ]
, p [] [ text "Arrows keys to move, space bar to jump." ]
]
-- MESH
type alias Vertex =
{ position : Vec3
, coord : Vec2
}
crate : WebGL.Mesh Vertex
crate =
WebGL.triangles <| List.concatMap rotatedSquare <|
[ (0, 0)
, (90, 0)
, (180, 0)
, (270, 0)
, (0, 90)
, (0, -90)
]
rotatedSquare : (Float, Float) -> List (Vertex, Vertex, Vertex)
rotatedSquare ( angleXZ, angleYZ ) =
let
transformMat =
Mat4.mul
(Mat4.makeRotate (degrees angleXZ) Vec3.j)
(Mat4.makeRotate (degrees angleYZ) Vec3.i)
transform vertex =
{ vertex
| position =
Mat4.transform transformMat vertex.position
}
transformTriangle (a, b, c) =
(transform a, transform b, transform c)
in
List.map transformTriangle square
square : List ( Vertex, Vertex, Vertex )
square =
let
topLeft = Vertex (vec3 -1 1 1) (vec2 0 1)
topRight = Vertex (vec3 1 1 1) (vec2 1 1)
bottomLeft = Vertex (vec3 -1 -1 1) (vec2 0 0)
bottomRight = Vertex (vec3 1 -1 1) (vec2 1 0)
in
[ ( topLeft, topRight, bottomLeft )
, ( bottomLeft, topRight, bottomRight )
]
-- SHADERS
type alias Uniforms =
{ texture : Texture.Texture
, perspective : Mat4
}
vertexShader : WebGL.Shader Vertex Uniforms { vcoord : Vec2 }
vertexShader =
[glsl|
attribute vec3 position;
attribute vec2 coord;
uniform mat4 perspective;
varying vec2 vcoord;
void main () {
gl_Position = perspective * vec4(position, 1.0);
vcoord = coord;
}
|]
fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 }
fragmentShader =
[glsl|
precision mediump float;
uniform sampler2D texture;
varying vec2 vcoord;
void main () {
gl_FragColor = texture2D(texture, vcoord);
}
|]