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 qualified Data.ByteString as BS
import Data.Fixed (mod')
import Data.Function ((&))
import Data.Int (Int32)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector.Storable as V
import Data.Word (Word32)
import Foreign.C.Types
import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Ptr
import Foreign.Storable (poke, sizeOf)
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 Linear
import Paths_vivant (getDataDir)
import SDL (($=))
import qualified 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 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
    ]