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 :: forall (m :: * -> *) box input.
(MonadResource m, MonadUnliftIO m, HasOutput box,
 GetOutput box ~ Box, HasOutput input, GetOutput input ~ Input) =>
box -> input -> m Process
spawn = 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
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 :: 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 <- 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
  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       :: Layout.Alignment
  , Input -> "scale" ::: Float
inputSize         :: Float
  , Input -> Vec4
inputColor        :: Vec4
  , Input -> Vec4
inputOutline      :: Vec4
  , Input -> "scale" ::: Float
inputOutlineWidth :: Float
  , Input -> "scale" ::: Float
inputSmoothing    :: Float
  }

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

    samplerId :: Int32
samplerId =
      if "scale" ::: Float
scale forall a. Ord a => a -> a -> Bool
> "scale" ::: Float
1 then
        forall a. Collection a -> a
Samplers.linear Collection Int32
Samplers.indices
      else
        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 <- forall a env (m :: * -> *).
(MonadVulkan env m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
Buffer.createCoherent (forall a. a -> Maybe a
Just Text
"Message") BufferUsageFlagBits
Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT Int
initialSize forall a. Monoid a => a
mempty
  Observer
observer <- forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO Allocated 'Coherent InstanceAttrs
messageData

  App GlobalHandles st
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register do
    Versioned (Allocated 'Coherent InstanceAttrs)
vData <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef Observer
observer
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (io :: * -> *) context (s :: Store) a.
(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 =
  forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m ()
Worker.observeIO_ source
messageP Observer
observer forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Allocated 'Coherent a -> Vector a -> m (Allocated 'Coherent a)
Buffer.updateCoherentResize_