diff options
| -rw-r--r-- | Main.hs | 109 |
1 files changed, 86 insertions, 23 deletions
@@ -1,23 +1,28 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main (main) where -import Control.Exception (bracket) -import Data.Bits ((.|.)) -import Data.ByteString (ByteString, packCString) -import Data.Coerce (coerce) -import Data.Int (Int32) -import Data.Vector as V -import Data.Vector() -import Foreign.C -import Foreign.C.ConstPtr (ConstPtr(..)) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Array (advancePtr) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek) -import qualified RGFW as RGFW -import qualified Vulkan.Core10 as Vk -import Vulkan.Zero (zero) +import Control.Exception (bracket) +import Data.Bits ((.|.), (.&.)) +import Data.ByteString (ByteString, packCString) +import Data.Coerce (coerce) +import Data.Int (Int32) +import Data.Vector (Vector) +import Foreign.C +import Foreign.C.ConstPtr (ConstPtr(..)) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) +import Unsafe.Coerce (unsafeCoerce) +import Vulkan.Zero (zero) + +import qualified Data.Vector as V +import qualified RGFW as RGFW +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Extensions.VK_KHR_surface as Vk height :: Int32 height = 400 @@ -25,23 +30,81 @@ width :: Int32 width = 800 main :: IO () -main = withRGFW "rgfw instance title" 0 $ \_ -> do +main = withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_enum RGFW.RGFW_initVulkan) $ \_ -> do exts <- alloca $ \extension_count -> do exts <- RGFW.rGFW_getRequiredInstanceExtensions_Vulkan extension_count cexts <- peek extension_count putStr $ show cexts - putStrLn " extensions required:" + putStr " extensions required: " vexts <- processExtensions cexts exts V.empty putStrLn $ show vexts return vexts Vk.withInstance (zero {Vk.enabledExtensionNames = exts}) Nothing bracket $ \i -> do - putStrLn $ show i withWindow "test window" 0 0 width height ((fromIntegral (RGFW.unwrapRGFW_windowFlags_enum RGFW.RGFW_windowCenter)) .|. (fromIntegral (RGFW.unwrapRGFW_windowFlags_enum RGFW.RGFW_windowNoResize))) $ \window -> do - res <- RGFW.rGFW_window_createSurface_Vulkan window (coerce $ Vk.instanceHandle i) nullPtr - ret <- gameloop window 0 - putStr "gameloop returned with code: " - putStrLn $ show ret + surface :: Vk.SurfaceKHR <- alloca $ \surfacePtr -> do + RGFW.rGFW_window_createSurface_Vulkan window (coerce $ Vk.instanceHandle i) surfacePtr + return . unsafeCoerce =<< peek surfacePtr + (_, pdevs) <- Vk.enumeratePhysicalDevices i + pdev <- pickPhysicalDevice pdevs surface + Vk.withDevice pdev zero Nothing bracket $ \dev -> do + qfprops <- Vk.getPhysicalDeviceQueueFamilyProperties pdev + queue <- Vk.getDeviceQueue dev (fromIntegral $ head $ getGraphicsQueues qfprops) 0 + putStrLn $ show queue + ret <- gameloop window 0 + putStr "gameloop returned with code: " + putStrLn $ show ret + +pickPhysicalDevice :: Vector Vk.PhysicalDevice -> Vk.SurfaceKHR -> IO Vk.PhysicalDevice +pickPhysicalDevice pdevs surface = do + validpdevs <- (V.filterM (\o -> isValidPhysicalDevice o surface) pdevs) + pickPhysicalDevice' validpdevs V.empty + +pickPhysicalDevice' :: Vector Vk.PhysicalDevice -> Vector Vk.PhysicalDevice -> IO Vk.PhysicalDevice +pickPhysicalDevice' pdevs opts = if V.null pdevs + then do + props <- Vk.getPhysicalDeviceProperties $ V.head opts + putStr "Selected physical device of type: " + putStrLn $ show props.deviceType + return $ V.head opts + else do + props <- Vk.getPhysicalDeviceProperties $ V.head pdevs + case props.deviceType of + Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU -> pickPhysicalDevice' (V.tail pdevs) (V.cons (V.head pdevs) opts) + Vk.PHYSICAL_DEVICE_TYPE_CPU -> pickPhysicalDevice' (V.tail pdevs) opts + _ -> pickPhysicalDevice' (V.tail pdevs) (V.snoc opts (V.head pdevs)) + +-- returns list of queueFamilyIndex whick support a graphics pipeline +getGraphicsQueues :: Vector Vk.QueueFamilyProperties -> [Int] +getGraphicsQueues qfprops = getGraphicsQueues' qfprops 0 [] + +getGraphicsQueues' :: Vector Vk.QueueFamilyProperties -> Int -> [Int] -> [Int] +getGraphicsQueues' qfprops i is = if V.null qfprops then is else + if zero /= (Vk.QUEUE_GRAPHICS_BIT .&. (V.head qfprops).queueFlags) + then getGraphicsQueues' (V.tail qfprops) (i + 1) (i:is) + else getGraphicsQueues' (V.tail qfprops) (i + 1) is + +-- returns list of queueFamilyIndex which support presentation +getSurfaceSupport :: Vk.PhysicalDevice -> Vk.SurfaceKHR -> IO [Int] +getSurfaceSupport pdev surface = do + qfprops <- Vk.getPhysicalDeviceQueueFamilyProperties pdev + getSurfaceSupport' pdev surface (V.length qfprops - 1) [] + +getSurfaceSupport' :: Vk.PhysicalDevice -> Vk.SurfaceKHR -> Int -> [Int] -> IO [Int] +getSurfaceSupport' pdev surface i is = if i < 0 then return is else do + support <- Vk.getPhysicalDeviceSurfaceSupportKHR pdev (fromIntegral i) surface + if support + then getSurfaceSupport' pdev surface (i - 1) (i:is) + else getSurfaceSupport' pdev surface (i - 1) is +isValidPhysicalDevice :: Vk.PhysicalDevice -> Vk.SurfaceKHR-> IO Bool +isValidPhysicalDevice pdev surface = do + qfprops <- Vk.getPhysicalDeviceQueueFamilyProperties pdev + surfaceSupport <- getSurfaceSupport pdev surface + if null $ getGraphicsQueues qfprops + then return False + else if null surfaceSupport + then return False + else return True processExtensions :: CSize -> Ptr (ConstPtr CChar) -> Vector ByteString -> IO (Vector ByteString) processExtensions 0 _ extNames = return extNames |