keid-render-basic-0.1.0.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 Vulkan.Core10 qualified as Vk

import Engine.Types qualified as Engine
import Engine.UI.Layout qualified as Layout
import Engine.Vulkan.Types (HasVulkan)
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
  :: ( Worker.HasOutput box
     , Worker.GetOutput box ~ Layout.Box
     , Worker.HasOutput input
     , Worker.GetOutput input ~ Input
     ) => box -> input -> RIO env Process
spawn = Worker.spawnMerge2 mkAttrs

spawnFromR
  :: ( Resource.MonadResource (RIO env)
     , Worker.HasOutput box
     , Worker.GetOutput box ~ Layout.Box
     , Worker.HasOutput source
     )
  => box
  -> source
  -> (Worker.GetOutput source -> Input)
  -> RIO env (Resource.ReleaseKey, Resource.ReleaseKey, Process)
spawnFromR parent inputProc mkMessage = do
  inputP <- Worker.spawnMerge1 mkMessage inputProc
  messageP <- spawn parent inputP

  (,,messageP)
    <$> Worker.register inputP
    <*> Worker.register messageP

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
  context <- ask

  messageData <- Buffer.createCoherent context Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty
  observer <- Worker.newObserverIO messageData

  void $! Resource.register do
    vData <- readIORef observer
    Buffer.destroyAll context vData

  pure observer

observe
  :: ( HasVulkan env
     , Worker.HasOutput source
     , Worker.GetOutput source ~ Storable.Vector EvanwSdf.InstanceAttrs
     )
  => source
  -> Observer -> RIO env ()
observe messageP observer = do
  context <- ask
  Worker.observeIO_ messageP observer $
    Buffer.updateCoherentResize_ context