blob: ece3ce8332195984334124a21092995710d3b4fc (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
{-# LANGUAGE DataKinds #-}
{-# 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 (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
width :: Int32
width = 800
main :: IO ()
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
vexts <- processExtensions cexts exts V.empty
return vexts
Vk.withInstance (zero {Vk.enabledExtensionNames = exts}) Nothing bracket $ \i -> do
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
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
gqueueIndex <- return $ fromIntegral $ head $ getGraphicsQueues qfprops
gqueue <- Vk.getDeviceQueue dev gqueueIndex 0
pqueueIndex <- return . fromIntegral . head =<< getSurfaceSupport pdev surface
pqueue <- Vk.getDeviceQueue dev pqueueIndex 0
Vk.withCommandPool dev (zero {Vk.queueFamilyIndex = gqueueIndex, Vk.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT}) Nothing bracket $ \gpool -> do
Vk.withCommandBuffers dev (zero {Vk.commandPool = gpool, Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY, Vk.commandBufferCount = 2}) bracket $ \gcbuffer -> do
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
-- checks that a device has the requisite capabilities
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
-- type conversion
processExtensions :: CSize -> Ptr (ConstPtr CChar) -> Vector ByteString -> IO (Vector ByteString)
processExtensions 0 _ extNames = return extNames
processExtensions count strs extNames = do
str <- peek strs
extName <- packCString (coerce str)
processExtensions (count - 1) (advancePtr strs 1) $ V.snoc extNames extName
gameloop :: Ptr RGFW.RGFW_window -> RGFW.RGFW_bool -> IO ()
gameloop window 0 = gameloop window =<< RGFW.rGFW_window_shouldClose window
gameloop _ _ = return ()
withWindow :: String -> Int32 -> Int32 -> Int32 -> Int32 -> RGFW.RGFW_windowFlags -> (Ptr RGFW.RGFW_window -> IO r) -> IO r
withWindow name x y w h flags io = withCString name $ \str -> do
window <- RGFW.rGFW_createWindow (ConstPtr str) (RGFW.I32 x) (RGFW.I32 y) (RGFW.I32 w) (RGFW.I32 h) flags
o0 <- io window
RGFW.rGFW_window_close window
return o0
withRGFW :: String -> RGFW.RGFW_initFlags -> (Int32 -> IO r) -> IO r
withRGFW title flags io = withCString title $ \str -> do
ret_code <- RGFW.rGFW_init (ConstPtr str) flags
o0 <- io $ fromIntegral ret_code
RGFW.rGFW_deinit
return o0
|
