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 :: box -> input -> RIO env Process
spawn = (GetOutput box -> GetOutput input -> Vector InstanceAttrs)
-> box -> input -> RIO env Process
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 GetOutput box -> GetOutput input -> Vector InstanceAttrs
Box -> Input -> Vector InstanceAttrs
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 :: box
-> source
-> (GetOutput source -> Input)
-> RIO env (ReleaseKey, ReleaseKey, Process)
spawnFromR box
parent source
inputProc GetOutput source -> Input
mkMessage = do
  Merge Input
inputP <- (GetOutput source -> Input) -> source -> RIO env (Merge Input)
forall (m :: * -> *) i o.
(MonadUnliftIO m, HasOutput i) =>
(GetOutput i -> o) -> i -> m (Merge o)
Worker.spawnMerge1 GetOutput source -> Input
mkMessage source
inputProc
  Process
messageP <- box -> Merge Input -> RIO env Process
forall box input env.
(HasOutput box, GetOutput box ~ Box, HasOutput input,
 GetOutput input ~ Input) =>
box -> input -> RIO env Process
spawn box
parent Merge Input
inputP

  (,,Process
messageP)
    (ReleaseKey -> ReleaseKey -> (ReleaseKey, ReleaseKey, Process))
-> RIO env ReleaseKey
-> RIO env (ReleaseKey -> (ReleaseKey, ReleaseKey, Process))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Merge Input -> RIO env ReleaseKey
forall (m :: * -> *) process.
(MonadResource m, HasWorker process) =>
process -> m ReleaseKey
Worker.register Merge Input
inputP
    RIO env (ReleaseKey -> (ReleaseKey, ReleaseKey, Process))
-> RIO env ReleaseKey -> RIO env (ReleaseKey, ReleaseKey, Process)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Process -> RIO env ReleaseKey
forall (m :: * -> *) process.
(MonadResource m, HasWorker process) =>
process -> m ReleaseKey
Worker.register Process
messageP

data Input = Input
  { Input -> Text
inputText         :: Text
  , Input -> Int32
inputFontId       :: Int32
  , Input -> Container
inputFont         :: Font.Container
  , Input -> Alignment
inputOrigin       :: Layout.Alignment
  , Input -> Float
inputSize         :: Float
  , Input -> Vec4
inputColor        :: Vec4
  , Input -> Vec4
inputOutline      :: Vec4
  , Input -> Float
inputOutlineWidth :: Float
  , Input -> 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{Float
Int32
Text
Vec4
Alignment
Container
inputSmoothing :: Float
inputOutlineWidth :: Float
inputOutline :: Vec4
inputColor :: Vec4
inputSize :: Float
inputOrigin :: Alignment
inputFont :: Container
inputFontId :: Int32
inputText :: Text
$sel:inputSmoothing:Input :: Input -> Float
$sel:inputOutlineWidth:Input :: Input -> Float
$sel:inputOutline:Input :: Input -> Vec4
$sel:inputColor:Input :: Input -> Vec4
$sel:inputSize:Input :: Input -> Float
$sel:inputOrigin:Input :: Input -> Alignment
$sel:inputFont:Input :: Input -> Container
$sel:inputFontId:Input :: Input -> Int32
$sel:inputText:Input :: Input -> Text
..} =
  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{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
    InstanceAttrs -> [InstanceAttrs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure InstanceAttrs :: Vec4
-> Vec4
-> Vec4
-> Vec4
-> Int32
-> Int32
-> Float
-> Float
-> InstanceAttrs
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 :: Float
smoothing    = Float
inputSmoothing -- 1/16
      , $sel:outlineWidth:InstanceAttrs :: Float
outlineWidth = Float
inputOutlineWidth -- 3/16
      }
  where
    (Float
scale, [PutChar]
chars) = Vec2
-> Vec2
-> Alignment
-> Float
-> Container
-> ("Line" ::: [Char])
-> (Float, [PutChar])
Font.putLine
      Vec2
boxSize
      Vec2
boxPosition
      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 :: Int -> ResourceT (StageRIO st) Observer
newObserver Int
initialSize = do
  App GlobalHandles st
context <- ResourceT (StageRIO st) (App GlobalHandles st)
forall r (m :: * -> *). MonadReader r m => m r
ask

  Allocated 'Coherent InstanceAttrs
messageData <- App GlobalHandles st
-> BufferUsageFlagBits
-> Int
-> Vector InstanceAttrs
-> ResourceT (StageRIO st) (Allocated 'Coherent InstanceAttrs)
forall a context (io :: * -> *).
(Storable a, HasVulkan context, MonadUnliftIO io) =>
context
-> BufferUsageFlagBits
-> Int
-> Vector a
-> io (Allocated 'Coherent a)
Buffer.createCoherent App GlobalHandles st
context 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

  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
    App GlobalHandles st
-> Versioned (Allocated 'Coherent InstanceAttrs) -> IO ()
forall (io :: * -> *) context (t :: * -> *) (s :: Store) a.
(MonadUnliftIO io, HasVulkan context, Foldable t) =>
context -> t (Allocated s a) -> io ()
Buffer.destroyAll App GlobalHandles st
context Versioned (Allocated 'Coherent InstanceAttrs)
vData

  pure Observer
observer

observe
  :: ( HasVulkan env
     , Worker.HasOutput source
     , Worker.GetOutput source ~ Storable.Vector EvanwSdf.InstanceAttrs
     )
  => source
  -> Observer -> RIO env ()
observe :: source -> Observer -> RIO env ()
observe source
messageP Observer
observer = do
  env
context <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask
  source
-> Observer
-> (Allocated 'Coherent InstanceAttrs
    -> GetOutput source -> RIO env (Allocated 'Coherent InstanceAttrs))
-> RIO env ()
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
  -> GetOutput source -> RIO env (Allocated 'Coherent InstanceAttrs))
 -> RIO env ())
-> (Allocated 'Coherent InstanceAttrs
    -> GetOutput source -> RIO env (Allocated 'Coherent InstanceAttrs))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
    env
-> Allocated 'Coherent InstanceAttrs
-> Vector InstanceAttrs
-> RIO env (Allocated 'Coherent InstanceAttrs)
forall a context (io :: * -> *).
(Storable a, HasVulkan context, MonadUnliftIO io) =>
context
-> Allocated 'Coherent a -> Vector a -> io (Allocated 'Coherent a)
Buffer.updateCoherentResize_ env
context