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

import Codec.Wavefront

import Control.Monad.IO.Class
import Control.Monad.Trans.Resource

import qualified Data.Vector as V

import Foreign

import Linear (V3(..), V4(..))

import qualified VulkanMemoryAllocator as VMA
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Zero as Vk

-- internal imports

import Types

loadMeshes
  :: V.Vector Vertex
loadMeshes =
  V.fromList
    [ Vertex (V3 0.5 0.5 0)    (V3 0 0 0) (V4 0 1 0 1)
    , Vertex (V3 (-0.5) 0.5 0) (V3 0 0 0) (V4 0 1 0 1)
    , Vertex (V3 0 (-0.5) 0)   (V3 0 0 0) (V4 0 1 0 1)
    ]

uploadMesh
  :: (MonadResource m, MonadFail m)
  => V.Vector Vertex
  -> VMA.Allocator
  -> m Mesh
uploadMesh vertices allocator = do
  let bufferCreateInfo = Vk.zero
        { Vk.size  = fromIntegral $
          V.length vertices * sizeOf (Vertex (V3 0 0 0) (V3 0 0 0 ) (V4 0 0 0 0))
        , Vk.usage = Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT
        }
      allocationCreateInfo = Vk.zero
        { VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
        } :: VMA.AllocationCreateInfo
  (_, mesh) <- allocate
    (do
      (buffer, allocation, _) <- VMA.createBuffer allocator bufferCreateInfo allocationCreateInfo
      return (Mesh vertices (AllocatedBuffer buffer allocation))
      )
    (\(Mesh _ (AllocatedBuffer buffer allocation)) -> do
      putStrLn "destroying mesh"
      VMA.destroyBuffer allocator buffer allocation
      )

  (dataReleaseKey, dataPtr) <- allocate
    (VMA.mapMemory allocator (bufferAllocation $ meshBuffer mesh))
    (\_ -> VMA.unmapMemory allocator (bufferAllocation $ meshBuffer mesh))

  liftIO $ mapM_ (\(idx, vertex) ->
    poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex
    )
    (zip [0..] (V.toList vertices))

  release dataReleaseKey

  return mesh

loadFromObj
  :: (MonadResource m, MonadFail m)
  => FilePath
  -> VMA.Allocator
  -> m Mesh
loadFromObj filepath vma = do
  eitherObj <- liftIO $ fromFile filepath
  case eitherObj of
    Left err ->
      error ("loadFromObj:  loading mesh data: " <> err)
    Right obj -> do
      let vertices = digestFaces (objFaces obj) (objLocations obj)
      uploadMesh vertices vma
  where
    digestFaces :: V.Vector (Element Face) -> V.Vector Location -> V.Vector Vertex
    digestFaces faces locations =
      V.foldl
        (\acc (Element _ _ _ _ (Face fa fb fc others)) ->
          if not (null others)
          then
            error "loadFromObj: Non-triangular face detected"
          else
            let newVertices = V.map
                  (\faceIndex ->
                    let position = faceIndexToPosition faceIndex locations
                        normal   = V3 0 0 0
                        color    = V4 1 1 0 1
                    in
                      Vertex position normal color
                    )
                  (V.fromList [ fa, fb, fc ])
            in
              acc V.++ newVertices
          )
        V.empty
        faces
    faceIndexToPosition :: FaceIndex -> V.Vector Location -> V3 Float
    faceIndexToPosition index locations =
      let Location x y z _ = locations V.! (faceLocIndex index - 1)
      in
        V3 x y z
