{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module CommandBuffer where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Foreign
import Foreign.C.Types (CInt)
import Linear
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk

-- internal imports

import Devices
import Types

createCommandPool
  :: (MonadResource m)
  => Vk.PhysicalDevice
  -> Vk.Device
  -> m (Vk.CommandPool, Vk.Queue)
createCommandPool physicalDevice logicalDevice = do

  queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT

  let poolCreateInfo = Vk.zero
        { Vk.flags            = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT
        , Vk.queueFamilyIndex = queueFamilyIndex
        } :: Vk.CommandPoolCreateInfo

  graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0

  commandPool <- snd <$> allocate
    (Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
    (\commandPool -> do
      putStrLn "destroying command pool"
      Vk.destroyCommandPool logicalDevice commandPool Nothing
      )

  return (commandPool, graphicsQueue)

createCommandBuffer
  :: (MonadResource m)
  => Vk.Device
  -> Vk.CommandPool
  -> Int
  -> m (V.Vector Vk.CommandBuffer)
createCommandBuffer logicalDevice commandPool number = do

  let commandBufferAllocationInfo = Vk.zero
        { Vk.commandPool        = commandPool
        , Vk.level              = Vk.COMMAND_BUFFER_LEVEL_PRIMARY
        , Vk.commandBufferCount = 1
        }

  V.concat <$>
    replicateM number (Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo)

recordCommandBuffer
  :: (MonadResource m)
  => Vk.CommandBuffer
  -> Vk.RenderPass
  -> Vk.Framebuffer
  -> V2 CInt
  -> Vk.Pipeline
  -> Vk.PipelineLayout
  -> Maybe Mesh
  -> Int
  -> m ()
recordCommandBuffer
  commandBuffer
  renderPass
  frameBuffer
  (V2 width height)
  graphicsPipeline
  meshLayout
  mesh
  frameNumber
  = do

    let commandBufferBeginInfo = Vk.zero
          { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
          , Vk.inheritanceInfo = Nothing
          }

    Vk.beginCommandBuffer commandBuffer commandBufferBeginInfo

    let renderPassInfo = Vk.zero
          { Vk.renderPass  = renderPass
          , Vk.framebuffer = frameBuffer
          , Vk.renderArea  = Vk.Rect2D
            { offset = Vk.Offset2D
              { Vk.x = 0
              , Vk.y = 0
              }
            , extent = Vk.Extent2D
              { Vk.width  = fromIntegral width
              , Vk.height = fromIntegral height
              }
            }
          , Vk.clearValues = V.replicate 4 (Vk.Color $ Vk.Float32 0 0 0 1)
          }

    Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE

    Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS graphicsPipeline

    let viewport = Vk.zero
          { Vk.x        = 0
          , Vk.y        = 0
          , Vk.width    = fromIntegral width
          , Vk.height   = fromIntegral height
          , Vk.minDepth = 0
          , Vk.maxDepth = 1
          }
        scissor = Vk.Rect2D
          { Vk.offset = Vk.Offset2D
            { Vk.x = 0
            , Vk.y = 0
            }
          , Vk.extent = Vk.Extent2D
            { Vk.width = fromIntegral width
            , Vk.height = fromIntegral height
            }
          }

    Vk.cmdSetViewport commandBuffer 0 (V.singleton viewport)
    Vk.cmdSetScissor commandBuffer 0 (V.singleton scissor)

    liftIO $ maybe
      (Vk.cmdDraw commandBuffer 3 1 0 0)
      (\jmesh -> do
        let camPosition = V3 0 0 (-2)
            camCenter = V3 0 0 0
            camUp = V3 0 1 0
            view = lookAt camPosition camCenter camUp
            projection = perspective (pi/4) (800 / 600) 0.1 200
            modelRot = axisAngle (V3 0 1 0) (fromIntegral frameNumber / (10 * pi))
            model = mkTransformation modelRot (V3 0 0 0)
            pvm = projection !*! view !*! model
            constants = MeshPushConstants (V4 0 0 0 0) (transpose pvm)

        pointer <- castPtr <$> new constants
        Vk.cmdPushConstants
          commandBuffer
          meshLayout
          Vk.SHADER_STAGE_VERTEX_BIT
          0
          (fromIntegral $ sizeOf constants)
          pointer

        Vk.cmdBindVertexBuffers
          commandBuffer
          0
          (V.fromList [ allocatedBuffer $ meshBuffer jmesh ])
          (V.fromList [ 0 ])

        Vk.cmdDraw commandBuffer (fromIntegral $ V.length $ meshVertices jmesh) 1 0 0
        )
      mesh

    Vk.cmdEndRenderPass commandBuffer

    Vk.endCommandBuffer commandBuffer

createSyncObjects
  :: (MonadResource m, MonadFail m)
  => Vk.Device
  -> m (Vk.Semaphore, Vk.Semaphore, Vk.Fence)
createSyncObjects logicalDevice = do

  let semaphoreCreateInfo = Vk.zero
      fenceCreateInfo = Vk.zero
        { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT
        } :: Vk.FenceCreateInfo '[]

  [imageAvailableSemaphore, renderFinishedSemaphore] <- replicateM 2
    (snd <$> allocate
      (Vk.createSemaphore logicalDevice semaphoreCreateInfo Nothing)
      (\semaphore -> do
        putStrLn "destroying semaphore"
        Vk.destroySemaphore logicalDevice semaphore Nothing
        )
      )
  inFlightFence <- snd <$> allocate
    (Vk.createFence logicalDevice fenceCreateInfo Nothing)
    (\fence -> do
      putStrLn "destroying fence"
      Vk.destroyFence logicalDevice fence Nothing
      )

  return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence)
