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, Word8)
import Foreign.C.Types
import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Ptr
import Foreign.Storable (poke, sizeOf)
import qualified Graphics.GL.Compatibility33 as GL
import Graphics.Rendering.OpenGL (($=))
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 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.Noise
import Vivant.Renderer
import Vivant.Shader (createProgram)
import Vivant.Terrain

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 (-10) 10,
      cameraUp = normalize (V3 0 10 10),
      cameraFront = normalize (V3 0 10 (-10)),
      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,
    gameTerrain :: Maybe Terrain
  }
  deriving (Show)

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

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

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

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
      "Vivant"
      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.depthFunc $= Just GL.Less
  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight))

  game <- initResources

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

        draw game'

        SDL.glSwapWindow window

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

  loop game 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
  let events' = fmap SDL.eventPayload events
  let (k, m) = foldr handleEvents (keys, mouse) events'
  return
    . changeIfIn events' mouseWheel (\(k, m) -> (k, m {mouseWheel = 0}))
    $ changeIfIn events' mouseMoving (\(k, m) -> (k, m {mouseRelative = V2 0 0})) (k, m)
  where
    mouseMoving SDL.MouseMotionEvent {} = True
    mouseMoving _ = False
    mouseWheel SDL.MouseWheelEvent {} = True
    mouseWheel _ = False
    changeIfIn events event modification initial =
      if any event events
        then initial
        else modification initial

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 (mousePositionOld m) (mousePressed m) (mouseWheel m))
    SDL.MouseButtonEvent
      SDL.MouseButtonEventData
        { SDL.mouseButtonEventMotion = SDL.Pressed
        } ->
        (k, m {mousePressed = True})
    SDL.MouseButtonEvent
      SDL.MouseButtonEventData
        { SDL.mouseButtonEventMotion = SDL.Released
        } ->
        (k, m {mousePressed = False})
    SDL.MouseWheelEvent
      SDL.MouseWheelEventData
        { SDL.mouseWheelEventPos = V2 x y
        } ->
        (k, m {mouseWheel = y})
    SDL.QuitEvent {} ->
      (Set.insert escapeKey k, m)
    _ -> (k, m)

updateMouse :: MouseInputs -> Game -> Game
updateMouse mouse game =
  game
    { gameCamera =
        (gameCamera game)
          { cameraPos = newPos ^+^ (fromIntegral (mouseWheel mouse) *^ newFront),
            cameraFront = newFront,
            cameraUp = newUp
          }
    }
  where
    rotation v
      | mousePressed mouse =
        rotate
          ( axisAngle
              (V3 0 0 1)
              ( (/ 2) . toRadians . fromIntegral $
                  - (mouseRelative mouse ^. _x)
              )
          )
          v
      | otherwise = v
    newPos = rotation . cameraPos $ gameCamera game
    newUp = rotation . cameraUp $ gameCamera game
    newFront = normalize (V3 0 0 0 ^-^ newPos)

pixelRenderer :: Double -> Int -> Int -> Float
pixelRenderer n x y =
  fromRational . toRational $
    ( perlin3
        permutation
        ( (fromIntegral x - 32) / 16,
          (fromIntegral y - 32) / 16,
          n
        )
        + 1
    )

createTerrain :: [[Float]]
createTerrain =
  fmap (\y -> fmap (\x -> pixelRenderer 3 x y * 5) [0 .. 256]) [0 .. 256]

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

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

  prog <- createProgram

  setVertexAttribute prog "position" 3 0 0

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

  terrain <- initTerrain createTerrain prog

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

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

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

castV3 :: V3 a -> GL.Vector3 a
castV3 (V3 a b c) = GL.Vector3 a b c

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

  GL.currentProgram $= gameProgram game
  GL.bindVertexArrayObject $= rendererVao (terrainRenderer t)

  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 500

  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 "light_pos"
  GL.uniform ourColorLoc
    $= GL.Vector3 (0 :: Float) (128 * sin (fromIntegral tick / 2000)) (64 * abs (cos $ fromIntegral tick / 2000))
  --castV3 (cameraPos (gameCamera game))

  render $ terrainRenderer t

  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,
      -0.5,
      -0.5,
      0,
      0.5,
      0.5,
      0,
      -0.5,
      0.5,
      0,
      -0.5,
      -0.5,
      0,
      0.5,
      0.5,
      0
    ]

square :: V.Vector Float
square =
  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,
      -0.5,
      0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      0.5,
      0.5,
      -0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      -0.5,
      0.5,
      0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      0.5,
      0.5,
      -0.5,
      0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      -0.5,
      0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      0.5,
      0.5,
      0.5,
      0.5,
      -0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      0.5,
      0.5,
      -0.5,
      0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      -0.5,
      -0.5,
      -0.5,
      0.5,
      -0.5,
      0.5,
      0.5,
      -0.5,
      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
  ]

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