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.Type.Equality (type (~))
import Data.Vector.Storable qualified as Storable
import Geomancy (Vec4)
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.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 ~ Box
     , Worker.HasOutput input
     , Worker.GetOutput input ~ Input
     )
  => box
  -> input
  -> m Process
spawn :: forall (m :: * -> *) box input.
(MonadResource m, MonadUnliftIO m, HasOutput box,
 GetOutput box ~ Box, HasOutput input, GetOutput input ~ Input) =>
box -> input -> m Process
spawn = (GetOutput box -> GetOutput input -> Vector InstanceAttrs)
-> box -> input -> m Process
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, MonadResource m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 Box -> Input -> Vector InstanceAttrs
GetOutput box -> GetOutput input -> Vector InstanceAttrs
mkAttrs

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

data Input = Input
  { Input -> Text
inputText         :: Text
  , Input -> Int32
inputFontId       :: Int32
  , Input -> Container
inputFont         :: Font.Container
  , Input -> Alignment
inputOrigin       :: Alignment
  , Input -> Float
inputSize         :: Float
  , Input -> Vec4
inputColor        :: Vec4
  , Input -> Vec4
inputOutline      :: Vec4
  , Input -> Float
inputOutlineWidth :: Float
  , Input -> Float
inputSmoothing    :: Float
  }

mkAttrs :: Box -> Input -> Storable.Vector EvanwSdf.InstanceAttrs
mkAttrs :: Box -> Input -> Vector InstanceAttrs
mkAttrs Box{Alignment
position :: Alignment
size :: Alignment
position :: Box -> Alignment
size :: Box -> Alignment
..} Input{Float
Int32
Text
Alignment
Vec4
Container
$sel:inputText:Input :: Input -> Text
$sel:inputFontId:Input :: Input -> Int32
$sel:inputFont:Input :: Input -> Container
$sel:inputOrigin:Input :: Input -> Alignment
$sel:inputSize:Input :: Input -> Float
$sel:inputColor:Input :: Input -> Vec4
$sel:inputOutline:Input :: Input -> Vec4
$sel:inputOutlineWidth:Input :: Input -> Float
$sel:inputSmoothing:Input :: Input -> Float
inputText :: Text
inputFontId :: Int32
inputFont :: Container
inputOrigin :: Alignment
inputSize :: Float
inputColor :: Vec4
inputOutline :: Vec4
inputOutlineWidth :: Float
inputSmoothing :: Float
..} =
  if Float
inputSize Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1 then Vector InstanceAttrs
forall a. Monoid a => a
mempty else [InstanceAttrs] -> Vector InstanceAttrs
forall a. Storable a => [a] -> Vector a
Storable.fromList do
    Font.PutChar{Alignment
pcPos :: Alignment
pcSize :: Alignment
pcOffset :: Alignment
pcScale :: Alignment
$sel:pcPos:PutChar :: PutChar -> Alignment
$sel:pcSize:PutChar :: PutChar -> Alignment
$sel:pcOffset:PutChar :: PutChar -> Alignment
$sel:pcScale:PutChar :: PutChar -> Alignment
..} <- [PutChar]
chars
    InstanceAttrs -> [InstanceAttrs]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure EvanwSdf.InstanceAttrs
      { $sel:vertRect:InstanceAttrs :: Vec4
vertRect     = Alignment -> Alignment -> Vec4
Vec4.fromVec22 Alignment
pcPos Alignment
pcSize
      , $sel:fragRect:InstanceAttrs :: Vec4
fragRect     = Alignment -> Alignment -> Vec4
Vec4.fromVec22 Alignment
pcOffset Alignment
pcScale
      , $sel:color:InstanceAttrs :: Vec4
color        = Vec4
inputColor
      , $sel:outlineColor:InstanceAttrs :: Vec4
outlineColor = Vec4
inputOutline -- vec4 0 0.25 0 0.25
      , $sel:textureId:InstanceAttrs :: Int32
textureId    = Int32
inputFontId
      , $sel:samplerId:InstanceAttrs :: Int32
samplerId    = Int32
samplerId
      , $sel:smoothing:InstanceAttrs :: Float
smoothing    = Float
inputSmoothing -- 1/16
      , $sel:outlineWidth:InstanceAttrs :: Float
outlineWidth = Float
inputOutlineWidth -- 3/16
      }
  where
    (Float
scale, [PutChar]
chars) = Alignment
-> Alignment
-> Alignment
-> Float
-> Container
-> ("Line" ::: [Char])
-> (Float, [PutChar])
Font.putLine
      Alignment
size
      Alignment
position
      Alignment
inputOrigin
      Float
inputSize
      Container
inputFont
      (Text -> "Line" ::: [Char]
Text.unpack Text
inputText)

    samplerId :: Int32
samplerId =
      if Float
scale Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1 then
        Collection Int32 -> Int32
forall a. Collection a -> a
Samplers.linear Collection Int32
Samplers.indices
      else
        Collection Int32 -> Int32
forall a. Collection a -> a
Samplers.linear Collection Int32
Samplers.indices

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

type Observer = Worker.ObserverIO Buffer

newObserver :: Int -> ResourceT (Engine.StageRIO st) Observer
newObserver :: forall st. Int -> ResourceT (StageRIO st) Observer
newObserver Int
initialSize = do
  Allocated 'Coherent InstanceAttrs
messageData <- Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector InstanceAttrs
-> ResourceT (StageRIO st) (Allocated 'Coherent InstanceAttrs)
forall a env (m :: * -> *).
(MonadVulkan env m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
Buffer.createCoherent (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Message") BufferUsageFlagBits
Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT Int
initialSize Vector InstanceAttrs
forall a. Monoid a => a
mempty
  Observer
observer <- Allocated 'Coherent InstanceAttrs
-> ResourceT (StageRIO st) Observer
forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO Allocated 'Coherent InstanceAttrs
messageData

  App GlobalHandles st
context <- ResourceT (StageRIO st) (App GlobalHandles st)
forall r (m :: * -> *). MonadReader r m => m r
ask
  ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ())
-> ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall a b. (a -> b) -> a -> b
$! IO () -> ResourceT (StageRIO st) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register do
    Versioned (Allocated 'Coherent InstanceAttrs)
vData <- Observer -> IO (Versioned (Allocated 'Coherent InstanceAttrs))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef Observer
observer
    (Allocated 'Coherent InstanceAttrs -> IO ())
-> Versioned (Allocated 'Coherent InstanceAttrs) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (App GlobalHandles st -> Allocated 'Coherent InstanceAttrs -> IO ()
forall {k} (io :: * -> *) context (s :: Store) (a :: k).
(MonadUnliftIO io, HasVulkan context) =>
context -> Allocated s a -> io ()
Buffer.destroy App GlobalHandles st
context) Versioned (Allocated 'Coherent InstanceAttrs)
vData

  pure Observer
observer

observe
  :: ( MonadVulkan env m
     , Worker.HasOutput source
     , Worker.GetOutput source ~ Storable.Vector EvanwSdf.InstanceAttrs
     )
  => source
  -> Observer
  -> m ()
observe :: forall env (m :: * -> *) source.
(MonadVulkan env m, HasOutput source,
 GetOutput source ~ Vector InstanceAttrs) =>
source -> Observer -> m ()
observe source
messageP Observer
observer =
  source
-> Observer
-> (Allocated 'Coherent InstanceAttrs
    -> GetOutput source -> m (Allocated 'Coherent InstanceAttrs))
-> m ()
forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m ()
Worker.observeIO_ source
messageP Observer
observer Allocated 'Coherent InstanceAttrs
-> Vector InstanceAttrs -> m (Allocated 'Coherent InstanceAttrs)
Allocated 'Coherent InstanceAttrs
-> GetOutput source -> m (Allocated 'Coherent InstanceAttrs)
forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Allocated 'Coherent a -> Vector a -> m (Allocated 'Coherent a)
Buffer.updateCoherentResize_