path: root/src/Vivant.hs

{-  Vivant: Haskell OpenGL game.
    Copyright (C) 2020 Yann Herklotz

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
-}

module Main where

import           Control.Lens                                 ((.~), (^.))
import           Control.Monad
import           Data.Fixed                                   (mod')
import           Data.Function                                ((&))
import           Data.Int                                     (Int32)
import           Data.Set                                     (Set)
import qualified Data.Set                                     as Set
import           Data.Word                                    (Word32)
import           Foreign.C.Types
import           Foreign.Marshal.Alloc                        (free, malloc)
import           Foreign.Ptr
import           Foreign.Storable                             (poke, sizeOf)
import           Linear
import           SDL                                          (($=))
import           SDL.Raw.Enum                                 as SDL
import           SDL.Raw.Video                                as SDL (glSetAttribute)
import           SDL.Time                                     (ticks)
import           SDL.Vect
import           System.Exit                                  (exitFailure)
import           System.IO

import qualified Data.ByteString                              as BS
import qualified Data.Vector.Storable                         as V
import qualified Graphics.GL.Functions                        as GL (glUniformMatrix4fv)
import qualified Graphics.Rendering.OpenGL                    as GL
import qualified Graphics.Rendering.OpenGL.GL.Shaders.Uniform as GL (UniformLocation (..))
import qualified SDL

import           Paths_vivant                                 (getDataDir)
import           Vivant.Shader                                (createProgram)

screenWidth, screenHeight :: CInt
(screenWidth, screenHeight) = (640, 480)

data Camera = Camera
  { cameraPos   :: V3 Float
  , cameraUp    :: V3 Float
  , cameraFront :: V3 Float
  , cameraSpeed :: Float
  , cameraPitch :: Float
  , cameraYaw   :: Float
  } deriving (Show)

initialCamera :: Camera
initialCamera = Camera
  { cameraPos   = V3 0 0 10
  , cameraUp    = V3 0 1 0
  , cameraFront = V3 0 0 (-1)
  , cameraSpeed = 0.05
  , cameraPitch = 0
  , cameraYaw   = (-90)
  }

data Game = Game
  { gameProgram     :: Maybe (GL.Program)
  , gameVao         :: Maybe (GL.VertexArrayObject)
  , gameModelP      :: Ptr (M44 Float)
  , gameViewP       :: Ptr (M44 Float)
  , gameProjectionP :: Ptr (M44 Float)
  , gameCamera      :: Camera
  } deriving (Show)

initialGameState :: Game
initialGameState = Game
  { gameProgram     = Nothing
  , gameVao         = Nothing
  , gameModelP      = nullPtr
  , gameViewP       = nullPtr
  , gameProjectionP = nullPtr
  , gameCamera      = initialCamera
  }

data MouseInputs = MouseInputs
  { mousePosition    :: Point V2 Int32
  , mouseRelative    :: V2 Int32
  , mousePositionOld :: Maybe (V2 Int32)
  } deriving (Show)

initialMouse :: MouseInputs
initialMouse = MouseInputs
  { mousePosition = P (V2 400 300)
  , mouseRelative = V2 0 0
  , mousePositionOld = Nothing
  }

main :: IO ()
main = do
    SDL.initialize [SDL.InitVideo]
    SDL.HintRenderScaleQuality $= SDL.ScaleLinear
    do renderQuality <- SDL.get SDL.HintRenderScaleQuality
       when (renderQuality /= SDL.ScaleLinear) $
         putStrLn "Warning: Linear texture filtering not enabled!"

    window <-
      SDL.createWindow
        "SDL / OpenGL Example"
        SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight,
                           SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL}

    SDL.glSetAttribute SDL_GL_CONTEXT_PROFILE_MASK SDL_GL_CONTEXT_PROFILE_CORE
    SDL.glSetAttribute SDL_GL_CONTEXT_MAJOR_VERSION 3
    SDL.glSetAttribute SDL_GL_CONTEXT_MINOR_VERSION 2

    SDL.glSetAttribute SDL_GL_DOUBLEBUFFER 1
    SDL.glSetAttribute SDL_GL_DEPTH_SIZE 24

    SDL.showWindow window

    _ <- SDL.glCreateContext window

    GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight))

    game <- initResources

    let loop key mouse = do
          (keys', mouse') <- parseEvents key mouse

          draw game
          SDL.glSwapWindow window

          unless (Set.member escapeKey keys') (loop keys' mouse')

    loop Set.empty initialMouse

    mapM_ free [ gameModelP game
               , gameViewP game
               , gameProjectionP game
               ]

    SDL.destroyWindow window
    SDL.quit

noKeyModifier :: SDL.KeyModifier
noKeyModifier = SDL.KeyModifier False False False False False False False False False False False

escapeKey :: SDL.Keysym
escapeKey = SDL.Keysym SDL.ScancodeEscape SDL.KeycodeEscape noKeyModifier

parseEvents :: Set SDL.Keysym -> MouseInputs -> IO (Set SDL.Keysym, MouseInputs)
parseEvents keys mouse = do
    events <- SDL.pollEvents
    return $ foldr handleEvents (keys, mouse) (fmap SDL.eventPayload events)

handleEvents
  :: SDL.EventPayload
     -> (Set SDL.Keysym, MouseInputs) -> (Set SDL.Keysym, MouseInputs)
handleEvents event (k, m) =
    case event of
      SDL.KeyboardEvent (SDL.KeyboardEventData { SDL.keyboardEventKeyMotion = e
                                               , SDL.keyboardEventKeysym = k'}) ->
        ((if e == SDL.Released then Set.delete else Set.insert) k' k, m)

      SDL.MouseMotionEvent (SDL.MouseMotionEventData { SDL.mouseMotionEventPos = pos
                                                     , SDL.mouseMotionEventRelMotion = vel
                                                     }) ->
        (k, MouseInputs pos vel Nothing)

      SDL.QuitEvent{} ->
        (Set.insert escapeKey k, m)

      _ -> (k, m)


updateMouse :: MouseInputs -> Game -> Game
updateMouse mouse game =
  game { gameCamera = (gameCamera game)
                  { cameraFront = front
                  , cameraPitch = pitchDegrees
                  , cameraYaw   = yawDegrees
                  }
       }
  where
    camera = gameCamera game
    front = normalize $ V3 (cos pitch * cos yaw) (sin pitch) (cos pitch * sin yaw)
    pitch = toRadians pitchDegrees
    yaw   = toRadians yawDegrees
    pitchDegrees = min 89 . max (-89) $ cameraPitch camera + negate dy
    yawDegrees   = (`mod'` 360) $ cameraYaw camera + dx
    sensitivity = 0.05
    V2 dx dy = (* sensitivity) . fromIntegral <$>
               if P (mouseRelative mouse) == mousePosition mouse
               then V2 0 0
               else mouseRelative mouse

setVertexAttribute :: GL.Program -> String -> Int -> Int -> Int -> IO ()
setVertexAttribute program name vertices stride offset = do
    let floatSize = sizeOf (1.0 :: Float)
    attrib <- GL.get $ GL.attribLocation program name
    GL.vertexAttribPointer attrib $= (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float
                                       (fromIntegral $ stride * floatSize)
                                       (plusPtr nullPtr (offset * floatSize)))
    GL.vertexAttribArray attrib $= GL.Enabled

getUniformLocation :: GL.UniformLocation -> GL.GLint
getUniformLocation (GL.UniformLocation i) = i

initResources :: IO Game
initResources = do
    vao <- GL.genObjectName
    GL.bindVertexArrayObject $= Just vao

    vbo <- GL.genObjectName
    GL.bindBuffer GL.ArrayBuffer $= Just vbo
    V.unsafeWith vertices $ \ptr ->
        GL.bufferData GL.ArrayBuffer $= (vectorSize vertices, castPtr ptr, GL.StaticDraw)

    prog <- createProgram

    setVertexAttribute prog "position" 2 0 0

    modelP <- malloc
    viewP <- malloc
    projectionP <- malloc

    return $ initialGameState { gameProgram = Just prog
                              , gameVao = Just vao
                              , gameModelP = modelP
                              , gameViewP = viewP
                              , gameProjectionP = projectionP
                              }

-- | Convert degrees to radians
toRadians :: Float -> Float
toRadians = (*) (pi / 180)

scaledMat :: V4 (V4 Float) -> V4 (V4 Float)
scaledMat n = ((n * identity) & _w . _w .~ 1)

draw :: Game -> IO ()
draw game@(Game {gameProgram = Just p, gameVao = Just v}) = do
    tick <- ticks
    GL.clearColor $= GL.Color4 1 1 1 1
    GL.clear [GL.ColorBuffer, GL.DepthBuffer]

    GL.currentProgram $= gameProgram game
    GL.bindVertexArrayObject $= gameVao game

    model <- getUniformLocation <$> GL.uniformLocation p "model"
    view <- getUniformLocation <$> GL.uniformLocation p "view"
    projection <- getUniformLocation <$> GL.uniformLocation p "projection"

    let camera = gameCamera game
        cameraPosition = cameraPos camera
        targetPosition = cameraPosition ^+^ cameraFront camera
        viewMatrix = lookAt cameraPosition targetPosition (cameraUp camera)
        projectionMatrix = perspective (toRadians 45) (640/480) 0.1 100

    poke (gameViewP game) viewMatrix
    poke (gameProjectionP game) projectionMatrix

    GL.glUniformMatrix4fv view 1 1 (castPtr (gameViewP game))
    GL.glUniformMatrix4fv projection 1 1 (castPtr (gameProjectionP game))

    ourColorLoc <- GL.uniformLocation p "ourColour"
    GL.uniform ourColorLoc $= (GL.Vector4 (1::Float) (sin (fromIntegral tick / 500) / 2 + 0.5) 1 1)

    forM_ locs $ \l -> do
        let modelMatrix = mkTransformation (axisAngle (V3 1 0 0) 0) l
        poke (gameModelP game) modelMatrix
        GL.glUniformMatrix4fv model 1 1 (castPtr (gameModelP game))
        GL.drawArrays GL.Triangles 0 6

    GL.bindVertexArrayObject $= Nothing
    return ()

vectorSize :: (Num b, V.Storable a) => V.Vector a -> b
vectorSize array = fromIntegral $ V.length array * sizeOf (1.0 :: Float)

vertices :: V.Vector Float
vertices = V.fromList [  0.5, -0.5
                      , -0.5, -0.5
                      ,  0.5,  0.5
                      , -0.5,  0.5
                      , -0.5, -0.5
                      ,  0.5,  0.5
                      ]

locs :: [V3 Float]
locs = [ V3 0 0 0
       , V3 1 0 0
       , V3 2 0 0
       , V3 3 0 0
       , V3 4 0 0
       , V3 0 1 0
       , V3 1 1 0
       , V3 2 1 0
       , V3 3 1 0
       , V3 4 1 0
       ]

texCoords :: V.Vector Float
texCoords = V.fromList [   0, 0
                       ,   1, 0
                       , 0.5, 1
                       ]