vulkan-tutorial/src/Main.hs

136 lines
4.2 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Main where
import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits
import Data.ByteString.Char8
import qualified Data.Map.Strict as M
import Data.Time.Clock
import qualified Data.Vector as V
import qualified SDL hiding (V2)
import System.IO (stdout)
import System.Mem
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import Init
import Draw (drawFrame)
import Types
main :: IO ()
main = do
renderablesContainer <- STM.newTMVarIO (V.empty)
meshMap <- STM.newTMVarIO (M.empty)
materialMap <- STM.newTMVarIO (M.empty)
textureMap <- STM.newTMVarIO (M.empty)
frameNumber <- STM.newTMVarIO 0
let initState = ReadState
{ renderables = renderablesContainer
, meshLibrary = meshMap
, materialLibrary = materialMap
, textureLibrary = textureMap
}
runRender initState $ do
engineData <- initEngine
SDL.showWindow $ engineWindow engineData
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
time <- liftIO $ STM.newTMVarIO =<< getCurrentTime
average <- liftIO $ STM.newTMVarIO 0
-- main loop
whileM_
(liftIO $ STM.atomically $ STM.readTMVar quit
)
( do
liftIO performMajorGC
now <- liftIO getCurrentTime
before <- liftIO $ STM.atomically $ STM.swapTMVar time now
let timeDiff = diffUTCTime now before
fps = recip $ nominalDiffTimeToSeconds timeDiff
liftIO $ hPutStr stdout $ pack $ "Current FPS: " <> show (floor fps) <> " \r"
number <- liftIO $ STM.atomically $ do
number <- STM.readTMVar frameNumber
if number == 0 then
void $ STM.swapTMVar average fps
else do
oldAverage <- STM.readTMVar average
let newAverage = (oldAverage * fromIntegral number + fps) / frameCount
frameCount = fromIntegral number + 1
void $ STM.swapTMVar average newAverage
void $ STM.swapTMVar frameNumber (succ number)
return number
-- draw
-- liftIO $ putStr $ show (recip $ nominalDiffTimeToSeconds timeDiff) <> "\r"
drawFrame engineData number
-- poll events
evs <- liftIO SDL.pollEvents
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
_ -> return ()
)
evs
)
fps <- liftIO $ STM.atomically $ STM.readTMVar average
liftIO $ hPutStr stdout $
"\n" <>
"Average FPS: " <> pack (show fps) <> "\n"
Vk.deviceWaitIdle $ engineLogicalDevice engineData
createBufferView
:: (MonadResource m)
=> Vk.Device
-> m (ReleaseKey, Vk.BufferView)
createBufferView logicalDevice = do
let bufferCreateInfo = Vk.zero
{ Vk.size = 1024
, Vk.usage =
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT .|.
Vk.BUFFER_USAGE_UNIFORM_TEXEL_BUFFER_BIT
, Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE
}
buffer <- snd <$>
(Vk.withBuffer logicalDevice bufferCreateInfo Nothing allocate)
let bufferViewCreateInfo = Vk.zero
{ Vk.buffer = buffer
, Vk.format = Vk.FORMAT_R32G32B32_SFLOAT
, Vk.offset = 0
, Vk.range = Vk.WHOLE_SIZE
}
Vk.withBufferView logicalDevice bufferViewCreateInfo Nothing allocate
allocateMemory
:: (MonadResource m)
=> Vk.Device
-> Vk.Buffer
-> m (ReleaseKey, Vk.DeviceMemory)
allocateMemory logicalDevice buffer = do
memoryRequirements <- Vk.getBufferMemoryRequirements logicalDevice buffer
let memoryAllocateInfo = Vk.zero
{ Vk.allocationSize = memoryRequirements.size
, Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String)
}
Vk.withMemory logicalDevice memoryAllocateInfo Nothing allocate