Thwomp WebGL Live JS (compiled)

Source

module Thwomp exposing (main)

-- Thwomp looks at your mouse. What is it up to?
--
-- Dependencies:
--   elm install elm/json
--   elm install elm-explorations/linear-algebra
--   elm install elm-explorations/webgl
--
-- Thanks to The PaperNES Guy for the texture:
--   https://the-papernes-guy.deviantart.com/art/Thwomps-Thwomps-Thwomps-186879685


import Browser
import Browser.Dom as Dom
import Browser.Events as E
import Html exposing (Html)
import Html.Attributes exposing (height, style, width)
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 Result
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 =
  { width : Float
  , height : Float
  , x : Float
  , y : Float
  , side : Maybe Texture.Texture
  , face : Maybe Texture.Texture
  }


init : () -> ( Model, Cmd Msg )
init _ =
  ( { width = 0
    , height = 0
    , x = 0
    , y = 0
    , face = Nothing
    , side = Nothing
    }
  , Cmd.batch
      [ Task.perform GotViewport Dom.getViewport
      , Task.attempt GotFace (Texture.loadWith options "https://elm-lang.org/images/thwomp-face.jpg")
      , Task.attempt GotSide (Texture.loadWith options "https://elm-lang.org/images/thwomp-side.jpg")
      ]
  )


options : Texture.Options
options =
  { magnify = Texture.nearest
  , minify = Texture.nearest
  , horizontalWrap = Texture.repeat
  , verticalWrap = Texture.repeat
  , flipY = True
  }



-- UPDATE


type Msg
  = GotFace (Result Texture.Error Texture.Texture)
  | GotSide (Result Texture.Error Texture.Texture)
  | GotViewport Dom.Viewport
  | Resized Int Int
  | MouseMoved Float Float


update : Msg -> Model -> Model
update msg model =
  case msg of
    GotFace result ->
      { model
          | face = Result.toMaybe result
      }

    GotSide result ->
      { model
          | side = Result.toMaybe result
      }

    GotViewport { viewport } ->
      { model
          | width = viewport.width
          , height = viewport.height
      }

    Resized width height ->
      { model
          | width = toFloat width
          , height = toFloat height
      }

    MouseMoved x y ->
      { model
          | x = x
          , y = y
      }



-- SUBSCRIPTIONS


subscriptions : Model -> Sub Msg
subscriptions _ =
  Sub.batch
    [ E.onResize Resized
    , E.onMouseMove decodeMovement
    ]


decodeMovement : D.Decoder Msg
decodeMovement =
  D.map2 MouseMoved
    (D.field "pageX" D.float)
    (D.field "pageY" D.float)



-- VIEW


view : Model -> Html Msg
view model =
  case Maybe.map2 Tuple.pair model.face model.side of
    Nothing ->
      Html.text "Loading textures..."

    Just (face, side) ->
      let
        perspective =
          toPerspective model.x model.y model.width model.height
      in
      WebGL.toHtml
        [ style "display" "block"
        , style "position" "absolute"
        , style "left" "0"
        , style "top" "0"
        , width (round model.width)
        , height (round model.height)
        ]
        [ WebGL.entity vertexShader fragmentShader faceMesh
            { perspective = perspective
            , texture = face
            }
        , WebGL.entity vertexShader fragmentShader sidesMesh
            { perspective = perspective
            , texture = side
            }
        ]


toPerspective : Float -> Float -> Float -> Float -> Mat4
toPerspective x y width height =
  let
    eye =
      Vec3.scale 6 <| Vec3.normalize <|
        vec3 (0.5 - x / width) (y / height - 0.5) 1
  in
  Mat4.mul
    (Mat4.makePerspective 45 (width / height) 0.01 100)
    (Mat4.makeLookAt eye (vec3 0 0 0) Vec3.j)



-- MESHES


type alias Vertex =
  { position : Vec3
  , coord : Vec2
  }


faceMesh : WebGL.Mesh Vertex
faceMesh =
  WebGL.triangles square


sidesMesh : WebGL.Mesh Vertex
sidesMesh =
  WebGL.triangles <| List.concatMap rotatedSquare <|
    [ (90, 0)
    , (180, 0)
    , (270, 0)
    , (0, 90)
    , (0, 270)
    ]


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 =
  { perspective : Mat4
  , texture : Texture.Texture
  }


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.xy;
    }
  |]


fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 }
fragmentShader =
  [glsl|
    precision mediump float;
    uniform sampler2D texture;
    varying vec2 vcoord;

    void main () {
      gl_FragColor = texture2D(texture, vcoord);
    }
  |]