vulkan-tutorial/src/Main.hs

110 lines
3 KiB
Haskell
Raw Normal View History

2022-01-14 07:59:38 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Main where
import Control.Monad
import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits
2022-07-14 05:02:10 +00:00
import qualified Data.Vector as V
2022-01-14 07:59:38 +00:00
import Data.Word
2022-07-10 17:31:44 +00:00
import qualified SDL hiding (V2)
2022-01-14 07:59:38 +00:00
import qualified Control.Concurrent.STM as STM
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import Init
2022-07-14 05:02:10 +00:00
import Draw (drawFrame)
2022-01-14 07:59:38 +00:00
main :: IO ()
main = runResourceT $ do
2022-07-14 05:02:10 +00:00
(window, logicalDevice, swapchain, graphicsQueue, commandBuffer, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
2022-01-14 07:59:38 +00:00
SDL.showWindow window
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
-- main loop
2022-07-14 05:02:10 +00:00
whileM_
(liftIO $ STM.atomically $ STM.readTMVar quit
2022-01-14 07:59:38 +00:00
)
( do
2022-07-14 05:02:10 +00:00
-- draw
drawFrame
logicalDevice
swapchain
graphicsQueue
(V.head commandBuffer)
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
2022-01-14 07:59:38 +00:00
-- poll events
2022-07-14 05:02:10 +00:00
evs <- liftIO SDL.pollEvents
2022-01-14 07:59:38 +00:00
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
2022-07-14 05:02:10 +00:00
void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
2022-01-14 07:59:38 +00:00
_ -> return ()
)
evs
)
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
2022-01-14 07:59:38 +00:00
}
buffer <- snd <$> allocate
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing)
(\buffer -> do
putStrLn "destroying buffer"
Vk.destroyBuffer logicalDevice buffer Nothing
2022-07-10 18:08:12 +00:00
)
2022-01-18 05:25:58 +00:00
let bufferViewCreateInfo = Vk.zero
{ Vk.buffer = buffer
, Vk.format = Vk.FORMAT_R32G32B32_SFLOAT
, Vk.offset = 0
, Vk.range = Vk.WHOLE_SIZE
2022-01-18 05:25:58 +00:00
}
2022-07-10 17:31:44 +00:00
allocate
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
(\bufferView -> do
putStrLn "destroying bufferView"
Vk.destroyBufferView logicalDevice bufferView Nothing
2022-07-10 17:31:44 +00:00
)
allocateMemory
2022-07-10 17:31:44 +00:00
:: (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 = (Vk.size :: Vk.MemoryRequirements -> Word64) memoryRequirements
, Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String)
2022-07-10 17:31:44 +00:00
}
allocate
(Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing)
(\memory -> do
putStrLn "Freeing memory"
Vk.freeMemory logicalDevice memory Nothing
2022-07-10 18:08:12 +00:00
)