118 lines
3.5 KiB
Haskell
118 lines
3.5 KiB
Haskell
{-# 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
|
|
import Data.Word
|
|
import qualified SDL hiding (V2)
|
|
import qualified Control.Concurrent.STM as STM
|
|
import qualified Vulkan as Vk
|
|
import qualified Vulkan.Zero as Vk
|
|
|
|
-- internal imports
|
|
|
|
import Init
|
|
import Draw (drawFrame)
|
|
import Types
|
|
|
|
main :: IO ()
|
|
main = runResourceT $ do
|
|
engineData <- initEngine
|
|
|
|
SDL.showWindow $ engineWindow engineData
|
|
|
|
-- create abort condition for upcoming lop
|
|
quit <- liftIO $ STM.newTMVarIO True
|
|
showPipeline <- liftIO $ STM.newTMVarIO Green
|
|
|
|
-- main loop
|
|
whileM_
|
|
(liftIO $ STM.atomically $ STM.readTMVar quit
|
|
)
|
|
( do
|
|
-- draw
|
|
drawFrame engineData showPipeline
|
|
-- 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
|
|
SDL.KeyboardEvent dat ->
|
|
case dat of
|
|
SDL.KeyboardEventData _ SDL.Released _ (SDL.Keysym _ SDL.KeycodeSpace _) ->
|
|
liftIO $ STM.atomically $ do
|
|
state <- STM.readTMVar showPipeline
|
|
void $ STM.swapTMVar showPipeline
|
|
(if state /= maxBound then succ state else state)
|
|
SDL.KeyboardEventData _ SDL.Released _ (SDL.Keysym _ SDL.KeycodeTab _) ->
|
|
liftIO $ STM.atomically $ do
|
|
state <- STM.readTMVar showPipeline
|
|
void $ STM.swapTMVar showPipeline
|
|
(if state /= minBound then pred state else state)
|
|
_ -> return ()
|
|
_ -> return ()
|
|
)
|
|
evs
|
|
)
|
|
|
|
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 <$> allocate
|
|
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing)
|
|
(\buffer -> do
|
|
putStrLn "destroying buffer"
|
|
Vk.destroyBuffer logicalDevice buffer Nothing
|
|
)
|
|
|
|
let bufferViewCreateInfo = Vk.zero
|
|
{ Vk.buffer = buffer
|
|
, Vk.format = Vk.FORMAT_R32G32B32_SFLOAT
|
|
, Vk.offset = 0
|
|
, Vk.range = Vk.WHOLE_SIZE
|
|
}
|
|
|
|
allocate
|
|
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
|
|
(\bufferView -> do
|
|
putStrLn "destroying bufferView"
|
|
Vk.destroyBufferView logicalDevice bufferView Nothing
|
|
)
|
|
|
|
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 = (Vk.size :: Vk.MemoryRequirements -> Word64) memoryRequirements
|
|
, Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String)
|
|
}
|
|
|
|
allocate
|
|
(Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing)
|
|
(\memory -> do
|
|
putStrLn "Freeing memory"
|
|
Vk.freeMemory logicalDevice memory Nothing
|
|
)
|