keid-render-basic-0.1.8.0: src/Engine/UI/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.Text qualified as Text
import Data.Vector.Storable qualified as Storable
import Geomancy (Vec4)
import Geomancy.Vec4 qualified as Vec4
import UnliftIO.Resource (MonadResource)
import Vulkan.Core10 qualified as Vk

import Engine.Types qualified as Engine
import Engine.UI.Layout qualified as Layout
import Engine.Vulkan.Types (MonadVulkan)
import Engine.Worker qualified as Worker
import Render.Font.EvanwSdf.Model qualified as EvanwSdf
import Render.Samplers qualified as Samplers
import Resource.Buffer qualified as Buffer
import Resource.Font.EvanW qualified as Font

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

spawn
  :: ( MonadResource m
     , MonadUnliftIO m
     , Worker.HasOutput box
     , Worker.GetOutput box ~ Layout.Box
     , Worker.HasOutput input
     , Worker.GetOutput input ~ Input
     )
  => box
  -> input
  -> m Process
spawn = Worker.spawnMerge2 mkAttrs

spawnFromR
  :: ( MonadResource m
     , MonadUnliftIO m
     , Worker.HasOutput box
     , Worker.GetOutput box ~ Layout.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
  , inputFontId       :: Int32
  , inputFont         :: Font.Container
  , inputOrigin       :: Layout.Alignment
  , inputSize         :: Float
  , inputColor        :: Vec4
  , inputOutline      :: Vec4
  , inputOutlineWidth :: Float
  , inputSmoothing    :: Float
  }

mkAttrs :: Layout.Box -> Input -> Storable.Vector EvanwSdf.InstanceAttrs
mkAttrs Layout.Box{..} Input{..} =
  if inputSize < 1 then mempty else Storable.fromList do
    Font.PutChar{..} <- chars
    pure EvanwSdf.InstanceAttrs
      { vertRect     = Vec4.fromVec22 pcPos pcSize
      , fragRect     = Vec4.fromVec22 pcOffset pcScale
      , color        = inputColor
      , outlineColor = inputOutline -- vec4 0 0.25 0 0.25
      , textureId    = inputFontId
      , samplerId    = samplerId
      , smoothing    = inputSmoothing -- 1/16
      , outlineWidth = inputOutlineWidth -- 3/16
      }
  where
    (scale, chars) = Font.putLine
      boxSize
      boxPosition
      inputOrigin
      inputSize
      inputFont
      (Text.unpack inputText)

    samplerId =
      if scale > 1 then
        Samplers.linear Samplers.indices
      else
        Samplers.linear Samplers.indices

type Buffer = Buffer.Allocated 'Buffer.Coherent EvanwSdf.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 EvanwSdf.InstanceAttrs
     )
  => source
  -> Observer
  -> m ()
observe messageP observer =
  Worker.observeIO_ messageP observer Buffer.updateCoherentResize_