surface and support checks

1 files changed, 86 insertions, 23 deletions

diff --git a/Main.hs b/Main.hs
index 1a81830..33f4819 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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