Message.hs

module Engine.UI.Message
  ( Process
  , Input(..)
  , spawn
  , spawnFromR
  , mkAttrs

  , Observer
  , Buffer
  , newObserver
  , observe
  ) where

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Resource qualified as Resource
import Data.Vector.Storable qualified as Storable
import Geomancy (Vec4, ivec2, vec2)
import Geomancy.Layout.Alignment (Alignment)
import Geomancy.Layout.Box (Box(..))
import Geomancy.Vec4 qualified as Vec4
import UnliftIO.Resource (MonadResource)
import Vulkan.Core10 qualified as Vk

import Engine.Types qualified as Engine
import Engine.Vulkan.Types (MonadVulkan)
import Engine.Worker qualified as Worker
import Render.Font.Msdf.Model qualified as Msdf
import Render.Samplers qualified as Samplers
import Resource.Buffer qualified as Buffer
import Resource.Font.Ktxf qualified as Ktxf

type Process = Worker.Merge (Storable.Vector Msdf.InstanceAttrs)

spawn
  :: ( MonadResource m
     , MonadUnliftIO m
     , Worker.HasOutput box
     , Worker.GetOutput box ~ Box
     , Worker.HasOutput input
     , Worker.GetOutput input ~ Input
     )
  => box
  -> input
  -> m Process
spawn box input = do
  shaped <- Worker.merge1M input \Input{inputFont, inputText} ->
    liftIO $ Ktxf.shape inputFont inputText
  Worker.spawnMerge3 mkAttrs box input shaped

spawnFromR
  :: ( MonadResource m
     , MonadUnliftIO m
     , Worker.HasOutput box
     , Worker.GetOutput box ~ Box
     , Worker.HasOutput source
     )
  => box
  -> source
  -> (Worker.GetOutput source -> Input)
  -> m Process
spawnFromR parent inputProc mkMessage = do
  inputP <- Worker.spawnMerge1 mkMessage inputProc
  spawn parent inputP

data Input = Input
  { inputText         :: Text
  , inputLineSize     :: Float
  , inputBreak        :: Ktxf.Strategy
  , inputFont         :: Ktxf.Stack
  , inputOrigin       :: Alignment
  , inputSize         :: Float
  , inputColor        :: Vec4
  , inputOutline      :: Vec4
  , inputOutlineWidth :: Float
  , inputSmoothing    :: Float
  } deriving (Generic)

mkAttrs :: Box -> Input -> Ktxf.ShapedText -> Storable.Vector Msdf.InstanceAttrs
mkAttrs box Input{..} shaped =
  Storable.fromList do
    Ktxf.PutChar{..} <- Ktxf.place box inputOrigin inputLineSize inputBreak inputSize inputFont shaped
    pure Msdf.InstanceAttrs
      { vertRect     = Vec4.fromVec22 pcPos pcSize -- get from char?
      , fragRect     = Vec4.fromVec22 pcOffset pcScale
      , textureIds    = ivec2 Samplers.indices.linear pcTextureId
      , sdfDist = vec2 pcDistanceLower pcDistanceRange
      , smoothing    = inputSmoothing -- 1/16
      , outlineWidth = inputOutlineWidth -- 3/16
      , color        = inputColor
      , outlineColor = inputOutline -- vec4 0 0.25 0 0.25
      }

type Buffer = Buffer.Allocated 'Buffer.Coherent Msdf.InstanceAttrs

type Observer = Worker.ObserverIO Buffer

newObserver :: Int -> ResourceT (Engine.StageRIO st) Observer
newObserver initialSize = do
  messageData <- Buffer.createCoherent (Just "Message") Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty
  observer <- Worker.newObserverIO messageData

  context <- ask
  void $! Resource.register do
    vData <- readIORef observer
    traverse_ (Buffer.destroy context) vData

  pure observer

observe
  :: ( MonadVulkan env m
     , Worker.HasOutput source
     , Worker.GetOutput source ~ Storable.Vector Msdf.InstanceAttrs
     )
  => source
  -> Observer
  -> m ()
observe messageP observer =
  Worker.observeIO_ messageP observer Buffer.updateCoherentResize_