path: root/Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Main (main) where

import Control.Exception      (bracket)
import Data.Bits              ((.|.), (.&.))
import Data.ByteString        (ByteString)
import Data.Coerce            (coerce)
import Data.Int               (Int32)
import Data.List              ((\\))
import Data.Vector            (Vector)
import FIR                    (compileTo, runCompilationsTH, CompilerFlag(SPIRV), Version(..))
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.CStruct.Extends (SomeStruct(..))
import Vulkan.Zero            (zero)

import qualified Data.ByteString                    as BS
import qualified Data.ByteString.Char8              as BSC
import qualified Data.Vector                        as V
import qualified RGFW                               as RGFW
import qualified Shaders                            as Shaders
import qualified Vulkan.Core10                      as Vk
import qualified Vulkan.Extensions.VK_KHR_surface   as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Vk

height :: Int32
height = 400
width :: Int32
width = 800

layers :: Vector ByteString
layers = V.fromList $ map BSC.pack ["VK_LAYER_KHRONOS_validation"]

extensions :: Vector ByteString
extensions = V.fromList $ map BSC.pack ["VK_KHR_swapchain"]

vert = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.vertPath [SPIRV (Version 1 0)] Shaders.vertex)] )
frag = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.fragPath [SPIRV (Version 1 0)] Shaders.fragment)] )

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.applicationInfo = Just (zero :: Vk.ApplicationInfo) { Vk.apiVersion = Vk.API_VERSION_1_0 }
                          , Vk.enabledExtensionNames = exts
                          , Vk.enabledLayerNames = layers
                          }) 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
            qfprops <- Vk.getPhysicalDeviceQueueFamilyProperties pdev
            let gqueueIndex = fromIntegral $ head $ getGraphicsQueues qfprops
            pqueueIndex <- return . fromIntegral . head =<< getSurfaceSupport pdev surface
            if pqueueIndex /= gqueueIndex then putStrLn "queues not the same index not supported, undefined ahead" else return ()
            Vk.withDevice pdev (zero { Vk.queueCreateInfos = V.singleton $ SomeStruct zero { Vk.queueFamilyIndex = gqueueIndex
                                                                                           , Vk.queuePriorities = V.singleton 1
                                                                                           }
                                     , Vk.enabledExtensionNames = extensions
                                     }) Nothing bracket $ \dev -> do
                gqueue <- Vk.getDeviceQueue dev gqueueIndex 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 = 1
                                                    }) bracket $ \cbuffers -> do
                        let gcbuffer = V.head cbuffers
                        caps <- Vk.getPhysicalDeviceSurfaceCapabilitiesKHR pdev surface
                        (_, forms) <- Vk.getPhysicalDeviceSurfaceFormatsKHR pdev surface
                        Vk.withSwapchainKHR dev zero { Vk.clipped = True
                                                     , Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
                                                     , Vk.imageArrayLayers = 1
                                                     , Vk.imageColorSpace = (V.head forms).colorSpace
                                                     , Vk.imageExtent = caps.currentExtent
                                                     , Vk.imageFormat = (V.head forms).format -- TODO fetch the best format
                                                     , Vk.imageSharingMode = Vk.SHARING_MODE_EXCLUSIVE
                                                     , Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
                                                     , Vk.minImageCount = caps.minImageCount
                                                     , Vk.presentMode = Vk.PRESENT_MODE_FIFO_KHR
                                                     , Vk.preTransform = caps.currentTransform
                                                     , Vk.queueFamilyIndices = V.singleton gqueueIndex -- TODO what if pqueue and gqueue are different!?
                                                     , Vk.surface = surface
                                                     } Nothing bracket $ \swapchain -> do
                            (_, images) <- Vk.getSwapchainImagesKHR dev swapchain
                            withImageViews dev (V.map (\image -> (zero :: Vk.ImageViewCreateInfo '[]) { Vk.image = image
                                                                                                      , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
                                                                                                      , Vk.subresourceRange = zero { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT
                                                                                                                                   , Vk.levelCount = Vk.REMAINING_MIP_LEVELS
                                                                                                                                   , Vk.layerCount = Vk.REMAINING_ARRAY_LAYERS
                                                                                                                                   }
                                                                                                      , Vk.format = (V.head forms).format -- TODO fetch the best format
                                                                                                      }) images) Nothing $ \imageViews -> do
                                let colorAttachmentRef = zero { Vk.attachment = 0
                                                              , Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
                                                              }
                                let colorAttachment = zero { Vk.format = (V.head forms).format -- TODO fetch the best format
                                                           , Vk.samples = Vk.SAMPLE_COUNT_1_BIT
                                                           , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
                                                           , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE
                                                           , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
                                                           , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
                                                           , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED
                                                           , Vk.finalLayout = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
                                                           } 
                                Vk.withRenderPass dev zero { Vk.attachments = V.singleton colorAttachment
                                                           , Vk.subpasses = V.singleton zero { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
                                                                                             , Vk.colorAttachments = V.singleton colorAttachmentRef
                                                                                             }
                                                           , Vk.dependencies = V.singleton zero { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
                                                                                                , Vk.dstSubpass = 0
                                                                                                , Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
                                                                                                , Vk.srcAccessMask = Vk.ACCESS_NONE
                                                                                                , Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
                                                                                                , Vk.dstAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
                                                                                                }
                                                           } Nothing bracket $ \pass -> do
                                    let fb = zero { Vk.height = caps.currentExtent.height
                                                  , Vk.width = caps.currentExtent.width
                                                  , Vk.renderPass = pass
                                                  , Vk.layers = 1
                                                  }
                                    let infos = V.map (\image -> (fb :: Vk.FramebufferCreateInfo '[]) { Vk.attachments = V.singleton image }) imageViews
                                    withFramebuffers dev infos Nothing $ \fbs -> do
                                        rawVert <- BS.readFile Shaders.vertPath
                                        rawFrag <- BS.readFile Shaders.fragPath
                                        withShaderModules dev (V.fromList [ zero { Vk.code = rawVert }, zero { Vk.code = rawFrag } ]) Nothing $ \mods -> do
                                            let vertMod = V.head mods
                                            let fragMod = V.head $ V.tail mods
                                            Vk.withPipelineLayout dev zero Nothing bracket $ \pipelineLayout -> do
                                                Vk.withGraphicsPipelines dev zero (V.map (SomeStruct) $ V.fromList [zero { Vk.stages = V.map (SomeStruct) $ V.fromList [ zero { Vk.stage = Vk.SHADER_STAGE_VERTEX_BIT
                                                                                                                                                                              , Vk.module' = vertMod
                                                                                                                                                                              , Vk.name = "main"
                                                                                                                                                                              }
                                                                                                                                                                       , zero { Vk.stage = Vk.SHADER_STAGE_FRAGMENT_BIT
                                                                                                                                                                              , Vk.module' = fragMod
                                                                                                                                                                              , Vk.name = "main"
                                                                                                                                                                              }]
                                                                                                                         , Vk.vertexInputState = Just zero
                                                                                                                         , Vk.inputAssemblyState = Just zero { Vk.topology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST }
                                                                                                                         , Vk.tessellationState = Just zero
                                                                                                                         , Vk.viewportState = Just $ SomeStruct zero { Vk.viewports = V.fromList [zero { Vk.x = 0
                                                                                                                                                                                                       , Vk.y = 0
                                                                                                                                                                                                       , Vk.width = fromIntegral caps.currentExtent.width
                                                                                                                                                                                                       , Vk.height = fromIntegral caps.currentExtent.height
                                                                                                                                                                                                       , Vk.minDepth = 0
                                                                                                                                                                                                       , Vk.maxDepth = 1
                                                                                                                                                                                                       }]
                                                                                                                                                                     , Vk.scissors = V.fromList [(zero :: Vk.Rect2D) { Vk.offset = zero
                                                                                                                                                                                                                     , Vk.extent = caps.currentExtent
                                                                                                                                                                                                                     }]
                                                                                                                                                                     }
                                                                                                                         , Vk.rasterizationState = Just $ SomeStruct zero { Vk.depthClampEnable = False
                                                                                                                                                                          , Vk.rasterizerDiscardEnable = False
                                                                                                                                                                          , Vk.polygonMode = Vk.POLYGON_MODE_FILL
                                                                                                                                                                          , Vk.cullMode = Vk.CULL_MODE_NONE
                                                                                                                                                                          , Vk.frontFace = Vk.FRONT_FACE_CLOCKWISE
                                                                                                                                                                          , Vk.depthBiasEnable = False
                                                                                                                                                                          , Vk.lineWidth = 1
                                                                                                                                                                          }
                                                                                                                         , Vk.multisampleState = Just $ SomeStruct zero { Vk.sampleShadingEnable = False
                                                                                                                                                                        , Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT
                                                                                                                                                                        }
                                                                                                                         , Vk.depthStencilState = Nothing
                                                                                                                         , Vk.colorBlendState = Just $ SomeStruct zero { Vk.attachments = V.singleton zero { Vk.blendEnable = False }}
                                                                                                                         , Vk.layout = pipelineLayout
                                                                                                                         , Vk.renderPass = pass
                                                                                                                         , Vk.subpass = 0
                                                                                                                         }]) Nothing bracket $ \(_, pipelines) -> do
                                                    let pipeline = V.head pipelines
                                                    Vk.withSemaphore dev zero Nothing bracket $ \sImageAvailable -> do
                                                        withSemaphores dev (V.fromList (take (V.length imageViews) (repeat zero))) Nothing $ \sRenderFinisheds -> do
                                                            Vk.withFence dev (zero { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT }) Nothing bracket $ \fInFlight -> do
                                                                ret <- gameloop dev swapchain gcbuffer gqueue fbs pass pipeline window (V.cons sImageAvailable sRenderFinisheds) fInFlight 0
                                                                putStr "gameloop returned"
                                                                Vk.deviceWaitIdle dev

gameloop :: Vk.Device -> Vk.SwapchainKHR -> Vk.CommandBuffer -> Vk.Queue -> Vector Vk.Framebuffer -> Vk.RenderPass -> Vk.Pipeline -> Ptr RGFW.RGFW_window -> Vector Vk.Semaphore -> Vk.Fence -> RGFW.RGFW_bool -> IO ()
gameloop dev swapchain gcbuffer queue fbs pass pipeline window ss f 0 = do
    RGFW.rGFW_pollEvents
    let fs = V.singleton f
    let sImageAvailable = V.head ss
    let sRenderFinisheds = V.tail ss
    _ <- Vk.waitForFences dev fs True 18446744073709551615
    Vk.resetFences dev fs
    (_, imageIndex) <- Vk.acquireNextImageKHR dev swapchain 18446744073709551615 sImageAvailable zero
    Vk.resetCommandBuffer gcbuffer zero
    Vk.useCommandBuffer gcbuffer zero $ do
        Vk.cmdUseRenderPass gcbuffer (zero { Vk.renderPass = pass
                                           , Vk.framebuffer = (V.!) fbs $ fromIntegral imageIndex
                                           , Vk.renderArea = (zero :: Vk.Rect2D) { Vk.offset = zero
                                                                                 , Vk.extent = zero { Vk.width = fromIntegral width
                                                                                                    , Vk.height = fromIntegral height
                                                                                                    }
                                                                                 }
                                           , Vk.clearValues = V.singleton (Vk.Color $ Vk.Float32 1 0 1 1)
                                           }) Vk.SUBPASS_CONTENTS_INLINE $ do
            Vk.cmdBindPipeline gcbuffer Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline
            Vk.cmdDraw gcbuffer 3 1 0 0
    Vk.queueSubmit queue (V.singleton (SomeStruct zero { Vk.waitSemaphores = V.singleton sImageAvailable
                                                       , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
                                                       , Vk.commandBuffers = V.singleton $ Vk.commandBufferHandle gcbuffer
                                                       , Vk.signalSemaphores = V.singleton $ (V.!) sRenderFinisheds (fromIntegral imageIndex)
                                                       })) f
    _ <- Vk.queuePresentKHR queue (zero { Vk.waitSemaphores = V.singleton $ (V.!) sRenderFinisheds (fromIntegral imageIndex)
                                        , Vk.swapchains = V.singleton swapchain
                                        , Vk.imageIndices = V.singleton imageIndex
                                        })
    gameloop dev swapchain gcbuffer queue fbs pass pipeline window ss f =<< RGFW.rGFW_window_shouldClose window
gameloop _ _ _ _ _ _ _ _ _ _ _ = return ()

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
        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
    (_, caps) <- Vk.enumerateDeviceExtensionProperties pdev Nothing
    if null $ getGraphicsQueues qfprops
    then return False
    else if null surfaceSupport
    then return False
    else if [] /= ((V.toList extensions) \\ (V.toList $ V.map (\p -> p.extensionName) caps))
    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 <- BS.packCString (coerce str)
    processExtensions (count - 1) (advancePtr strs 1) $ V.snoc extNames extName

withSemaphores :: Vk.Device -> Vector (Vk.SemaphoreCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.Semaphore -> IO r) -> IO r
withSemaphores dev infos alloc io = do
    ss <- mapM (\info -> Vk.createSemaphore dev info alloc) infos
    o0 <- io ss
    _ <- mapM (\s -> Vk.destroySemaphore dev s alloc) ss
    return o0

withFramebuffers :: Vk.Device -> Vector (Vk.FramebufferCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.Framebuffer -> IO r) -> IO r
withFramebuffers dev infos alloc io = do
    fbs <- mapM (\info -> Vk.createFramebuffer dev info alloc) infos
    o0 <- io fbs
    _ <- mapM (\fb -> Vk.destroyFramebuffer dev fb alloc) fbs
    return o0

withImageViews :: Vk.Device -> Vector (Vk.ImageViewCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.ImageView -> IO r) -> IO r
withImageViews dev infos alloc io = do
    imageViews <- mapM (\info -> Vk.createImageView dev info alloc) infos
    o0 <- io imageViews
    _ <- mapM (\imageView -> Vk.destroyImageView dev imageView alloc) imageViews
    return o0

withShaderModules :: Vk.Device -> Vector (Vk.ShaderModuleCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.ShaderModule -> IO r) -> IO r
withShaderModules dev infos alloc io = do
    mods <- mapM (\info -> Vk.createShaderModule dev info alloc) infos
    o0 <- io mods
    _ <- mapM (\mod -> Vk.destroyShaderModule dev mod alloc) mods
    return o0

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