module Stage.Loader.UI
  ( Settings(..)

  , UI(..)
  , spawn

  , Observer(..)
  , newObserver
  , observe
  ) where

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Resource qualified as Resource
import Geomancy (vec4)
import Geomancy.Transform qualified as Transform
import Vulkan.Core10 qualified as Vk

import Engine.Types qualified as Engine
import Engine.UI.Layout qualified as Layout
import Engine.UI.Message qualified as Message
import Engine.Vulkan.Types (HasVulkan, Queues)
import Engine.Worker qualified as Worker
import Geometry.Quad qualified as Quad
import Render.Samplers qualified as Samplers
import Render.Unlit.Textured.Model qualified as UnlitTextured
import Resource.Buffer qualified as Buffer
import Resource.Combined.Textures qualified as CombinedTextures
import Resource.Font.EvanW qualified as EvanW
import Resource.Model qualified as Model
import Resource.Model.Observer qualified as Observer
import Resource.Region qualified as Region
import Resource.Texture (Texture, Flat)

data Settings fonts textures = Settings
  { forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> Text
titleMessage :: Text
  , forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> Int32
backgroundIx :: Int32
  , forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> Int32
spinnerIx    :: Int32

  , forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures
-> Collection textures fonts (Int32, Texture Flat)
combined     :: CombinedTextures.Collection textures fonts (Int32, Texture Flat)
  , forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> fonts Container
fonts        :: fonts EvanW.Container

  , forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> forall a. fonts a -> a
smallFont    :: forall a . fonts a -> a
  , forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> forall a. fonts a -> a
largeFont    :: forall a . fonts a -> a
  }

data UI = UI
  { UI -> Process
titleP    :: Message.Process
  , UI -> Process
subtitleP :: Message.Process

  , UI -> Var Input
progressInput :: Worker.Var Message.Input
  , UI -> Process
progressP     :: Message.Process

  , UI -> Merge Stores
backgroundP :: Worker.Merge UnlitTextured.Stores
  , UI -> Merge Stores
spinnerP    :: Worker.Merge UnlitTextured.Stores

  , UI -> Model 'Staged
quadUV :: UnlitTextured.Model 'Buffer.Staged
  }

spawn
  :: Queues Vk.CommandPool
  -> Layout.BoxProcess
  -> Settings fonts textures
  -> Engine.StageRIO env (Resource.ReleaseKey, UI)
spawn :: forall (fonts :: * -> *) (textures :: * -> *) env.
Queues CommandPool
-> BoxProcess
-> Settings fonts textures
-> StageRIO env (ReleaseKey, UI)
spawn Queues CommandPool
pools BoxProcess
screenBoxP Settings{fonts Container
Int32
Text
Collection textures fonts (Int32, Texture Flat)
forall a. fonts a -> a
largeFont :: forall a. fonts a -> a
smallFont :: forall a. fonts a -> a
fonts :: fonts Container
combined :: Collection textures fonts (Int32, Texture Flat)
spinnerIx :: Int32
backgroundIx :: Int32
titleMessage :: Text
$sel:largeFont:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> forall a. fonts a -> a
$sel:smallFont:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> forall a. fonts a -> a
$sel:fonts:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> fonts Container
$sel:combined:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures
-> Collection textures fonts (Int32, Texture Flat)
$sel:spinnerIx:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> Int32
$sel:backgroundIx:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> Int32
$sel:titleMessage:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures -> Text
..} = forall (m :: * -> *) a.
MonadResource m =>
ResourceT m a -> m (ReleaseKey, a)
Region.run do
  Var Vec4
paddingVar <- forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Vec4
16
  BoxProcess
screenPaddedP <- forall (m :: * -> *) parent padding.
(MonadResource m, MonadUnliftIO m, HasOutput parent,
 GetOutput parent ~ Box, HasOutput padding,
 GetOutput padding ~ Vec4) =>
parent -> padding -> m BoxProcess
Layout.padAbs BoxProcess
screenBoxP Var Vec4
paddingVar

  -- Messages

  [BoxProcess]
sections <- forall (m :: * -> *) parent (t :: * -> *).
(MonadResource m, MonadUnliftIO m, HasOutput parent,
 GetOutput parent ~ Box, Traversable t) =>
((Float, Float) -> Vec4) -> parent -> t Float -> m (t BoxProcess)
Layout.splitsRelStatic (Float, Float) -> Vec4
Layout.sharePadsV BoxProcess
screenPaddedP [Float
2, Float
1, Float
1]

  (BoxProcess
titleBoxP, BoxProcess
subtitleBoxP, BoxProcess
progressBoxP) <- case [BoxProcess]
sections of
    [BoxProcess
titleBoxP, BoxProcess
subtitleBoxP, BoxProcess
progressBoxP] ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (BoxProcess
titleBoxP, BoxProcess
subtitleBoxP, BoxProcess
progressBoxP)
    [BoxProcess]
_ ->
      forall a. HasCallStack => [Char] -> a
error [Char]
"assert: shares in Traversable preserve structure"

  Process
titleP <- forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Input
title forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) box input.
(MonadResource m, MonadUnliftIO m, HasOutput box,
 GetOutput box ~ Box, HasOutput input, GetOutput input ~ Input) =>
box -> input -> m Process
Message.spawn BoxProcess
titleBoxP
  Process
subtitleP <- forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Input
subtitle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) box input.
(MonadResource m, MonadUnliftIO m, HasOutput box,
 GetOutput box ~ Box, HasOutput input, GetOutput input ~ Input) =>
box -> input -> m Process
Message.spawn BoxProcess
subtitleBoxP

  Var Input
progressInput <- forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Input
progress
  Process
progressP <- forall (m :: * -> *) box input.
(MonadResource m, MonadUnliftIO m, HasOutput box,
 GetOutput box ~ Box, HasOutput input, GetOutput input ~ Input) =>
box -> input -> m Process
Message.spawn BoxProcess
progressBoxP Var Input
progressInput

  -- Splash

  BoxProcess
backgroundBoxP <- forall (m :: * -> *) parent.
(MonadResource m, MonadUnliftIO m, HasOutput parent,
 GetOutput parent ~ Box) =>
Alignment -> ("dimensions" ::: Vec2) -> parent -> m BoxProcess
Layout.fitPlaceAbs Alignment
Layout.Center "dimensions" ::: Vec2
1.0 BoxProcess
screenBoxP

  Merge Stores
backgroundP <-
    forall (m :: * -> *) i o.
(MonadUnliftIO m, MonadResource m, HasOutput i) =>
(GetOutput i -> o) -> i -> m (Merge o)
Worker.spawnMerge1
      ( \GetOutput BoxProcess
box ->
          Int32 -> Int32 -> [Transform] -> Stores
UnlitTextured.stores1
              (forall a. Collection a -> a
Samplers.linear Collection Int32
Samplers.indices)
              Int32
backgroundIx
              [Box -> Transform
Layout.boxTransformAbs GetOutput BoxProcess
box]
      )
      BoxProcess
backgroundBoxP

  -- Spinner

  Timed () Transform
spinnerTransformTimeP <-
    forall (m :: * -> *) output.
(MonadUnliftIO m, MonadResource m) =>
Bool -> Int -> output -> m output -> m (Timed () output)
Worker.spawnTimed_ Bool
True Int
100 forall a. Monoid a => a
mempty do
      Double
t <- forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
      pure $ Float -> Transform
Transform.rotateZ (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
t)

  Merge Transform
spinnerTransformBoxP <-
    forall (m :: * -> *) i o.
(MonadUnliftIO m, MonadResource m, HasOutput i) =>
(GetOutput i -> o) -> i -> m (Merge o)
Worker.spawnMerge1
      (Box -> Transform
Layout.boxTransformAbs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("dimensions" ::: Vec2) -> Box -> ("dimensions" ::: Vec2, Box)
Layout.boxFitScale "dimensions" ::: Vec2
64)
      BoxProcess
subtitleBoxP

  Merge Stores
spinnerP <-
    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
      ( \GetOutput (Merge Transform)
place GetOutput (Timed () Transform)
turn ->
          Int32 -> Int32 -> [Transform] -> Stores
UnlitTextured.stores1
              (forall a. Collection a -> a
Samplers.linear Collection Int32
Samplers.indices)
              Int32
spinnerIx
              [GetOutput (Timed () Transform)
turn, GetOutput (Merge Transform)
place]
      )
      Merge Transform
spinnerTransformBoxP
      Timed () Transform
spinnerTransformTimeP

  -- Models

  Model 'Staged
quadUV <- forall env (m :: * -> *) pos attrs.
(MonadVulkan env m, Storable pos, Storable attrs) =>
Maybe Text
-> Queues CommandPool
-> [Vertex pos attrs]
-> Maybe [Word32]
-> m (Indexed 'Staged pos attrs)
Model.createStagedL
    (forall a. a -> Maybe a
Just Text
"quadUV")
    Queues CommandPool
pools
    (forall pos attrs. Quad (Vertex pos attrs) -> [Vertex pos attrs]
Quad.toVertices Quad (Vertex Packed ("dimensions" ::: Vec2))
Quad.texturedQuad)
    forall a. Maybe a
Nothing
  forall env (m :: * -> *) (storage :: Store) pos attrs.
(MonadVulkan env m, MonadResource m) =>
Indexed storage pos attrs -> m ()
Model.registerIndexed_ Model 'Staged
quadUV

  pure UI{Var Input
Process
Merge Stores
Model 'Staged
quadUV :: Model 'Staged
spinnerP :: Merge Stores
backgroundP :: Merge Stores
progressP :: Process
progressInput :: Var Input
subtitleP :: Process
titleP :: Process
$sel:quadUV:UI :: Model 'Staged
$sel:spinnerP:UI :: Merge Stores
$sel:backgroundP:UI :: Merge Stores
$sel:progressP:UI :: Process
$sel:progressInput:UI :: Var Input
$sel:subtitleP:UI :: Process
$sel:titleP:UI :: Process
..}
  where
    title :: Input
title = Message.Input
      { $sel:inputText:Input :: Text
inputText         = Text
titleMessage
      , $sel:inputOrigin:Input :: Alignment
inputOrigin       = Alignment
Layout.CenterBottom
      , $sel:inputSize:Input :: Float
inputSize         = Float
64
      , $sel:inputColor:Input :: Vec4
inputColor        = Float -> Float -> Float -> Float -> Vec4
vec4 Float
1 Float
0.5 Float
0.25 Float
1
      , $sel:inputFont:Input :: Container
inputFont         = forall a. fonts a -> a
largeFont fonts Container
fonts
      , $sel:inputFontId:Input :: Int32
inputFontId       = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. fonts a -> a
largeFont forall a b. (a -> b) -> a -> b
$ forall (textures :: * -> *) (fonts :: * -> *) a.
Collection textures fonts a -> fonts a
CombinedTextures.fonts Collection textures fonts (Int32, Texture Flat)
combined
      , $sel:inputOutline:Input :: Vec4
inputOutline      = Float -> Float -> Float -> Float -> Vec4
vec4 Float
0 Float
0 Float
0 Float
1
      , $sel:inputOutlineWidth:Input :: Float
inputOutlineWidth = Float
4forall a. Fractional a => a -> a -> a
/Float
16
      , $sel:inputSmoothing:Input :: Float
inputSmoothing    = Float
1forall a. Fractional a => a -> a -> a
/Float
16
      }

    subtitle :: Input
subtitle = Message.Input
      { $sel:inputText:Input :: Text
inputText         = Text
"Loading..."
      , $sel:inputOrigin:Input :: Alignment
inputOrigin       = Alignment
Layout.CenterTop
      , $sel:inputSize:Input :: Float
inputSize         = Float
32
      , $sel:inputColor:Input :: Vec4
inputColor        = Float -> Float -> Float -> Float -> Vec4
vec4 Float
0.5 Float
1 Float
0.25 Float
1
      , $sel:inputFont:Input :: Container
inputFont         = forall a. fonts a -> a
smallFont fonts Container
fonts
      , $sel:inputFontId:Input :: Int32
inputFontId       = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. fonts a -> a
smallFont forall a b. (a -> b) -> a -> b
$ forall (textures :: * -> *) (fonts :: * -> *) a.
Collection textures fonts a -> fonts a
CombinedTextures.fonts Collection textures fonts (Int32, Texture Flat)
combined
      , $sel:inputOutline:Input :: Vec4
inputOutline      = Float -> Float -> Float -> Float -> Vec4
vec4 Float
0 Float
0 Float
0 Float
1
      , $sel:inputOutlineWidth:Input :: Float
inputOutlineWidth = Float
4forall a. Fractional a => a -> a -> a
/Float
16
      , $sel:inputSmoothing:Input :: Float
inputSmoothing    = Float
1forall a. Fractional a => a -> a -> a
/Float
16
      }

    progress :: Input
progress = Message.Input
      { $sel:inputText:Input :: Text
inputText         = Text
""
      , $sel:inputOrigin:Input :: Alignment
inputOrigin       = Alignment
Layout.CenterBottom
      , $sel:inputSize:Input :: Float
inputSize         = Float
16
      , $sel:inputColor:Input :: Vec4
inputColor        = Float -> Float -> Float -> Float -> Vec4
vec4 Float
0.25 Float
0.5 Float
1 Float
1
      , $sel:inputFont:Input :: Container
inputFont         = forall a. fonts a -> a
smallFont fonts Container
fonts
      , $sel:inputFontId:Input :: Int32
inputFontId       = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. fonts a -> a
smallFont forall a b. (a -> b) -> a -> b
$ forall (textures :: * -> *) (fonts :: * -> *) a.
Collection textures fonts a -> fonts a
CombinedTextures.fonts Collection textures fonts (Int32, Texture Flat)
combined
      , $sel:inputOutline:Input :: Vec4
inputOutline      = Vec4
0
      , $sel:inputOutlineWidth:Input :: Float
inputOutlineWidth = Float
0
      , $sel:inputSmoothing:Input :: Float
inputSmoothing    = Float
1forall a. Fractional a => a -> a -> a
/Float
16
      }

data Observer = Observer
  { Observer -> [Observer]
messages   :: [Message.Observer]
  , Observer -> ObserverCoherent
background :: UnlitTextured.ObserverCoherent
  , Observer -> ObserverCoherent
spinner    :: UnlitTextured.ObserverCoherent
  }

newObserver :: UI -> ResourceT (Engine.StageRIO st) Observer
newObserver :: forall st. UI -> ResourceT (StageRIO st) Observer
newObserver UI{Var Input
Process
Merge Stores
Model 'Staged
quadUV :: Model 'Staged
spinnerP :: Merge Stores
backgroundP :: Merge Stores
progressP :: Process
progressInput :: Var Input
subtitleP :: Process
titleP :: Process
$sel:quadUV:UI :: UI -> Model 'Staged
$sel:spinnerP:UI :: UI -> Merge Stores
$sel:backgroundP:UI :: UI -> Merge Stores
$sel:progressP:UI :: UI -> Process
$sel:progressInput:UI :: UI -> Var Input
$sel:subtitleP:UI :: UI -> Process
$sel:titleP:UI :: UI -> Process
..} = do
  -- XXX: Generic?
  [Observer]
messages <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall st. Int -> ResourceT (StageRIO st) Observer
Message.newObserver Int
256)
    [ Process
titleP
    , Process
subtitleP
    , Process
progressP
    ]

  ObserverCoherent
background <- forall res env (m :: * -> *).
(VertexBuffers res, MonadVulkan env m) =>
Int -> Text -> ResourceT m (ObserverIO res)
Observer.newCoherent Int
1 Text
"background"
  ObserverCoherent
spinner <- forall res env (m :: * -> *).
(VertexBuffers res, MonadVulkan env m) =>
Int -> Text -> ResourceT m (ObserverIO res)
Observer.newCoherent Int
1 Text
"spinner"

  pure Observer{[Observer]
ObserverCoherent
spinner :: ObserverCoherent
background :: ObserverCoherent
messages :: [Observer]
$sel:spinner:Observer :: ObserverCoherent
$sel:background:Observer :: ObserverCoherent
$sel:messages:Observer :: [Observer]
..}

observe
  :: ( HasVulkan env
     )
  => UI
  -> Observer -> RIO env ()
observe :: forall env. HasVulkan env => UI -> Observer -> RIO env ()
observe UI{Var Input
Process
Merge Stores
Model 'Staged
quadUV :: Model 'Staged
spinnerP :: Merge Stores
backgroundP :: Merge Stores
progressP :: Process
progressInput :: Var Input
subtitleP :: Process
titleP :: Process
$sel:quadUV:UI :: UI -> Model 'Staged
$sel:spinnerP:UI :: UI -> Merge Stores
$sel:backgroundP:UI :: UI -> Merge Stores
$sel:progressP:UI :: UI -> Process
$sel:progressInput:UI :: UI -> Var Input
$sel:subtitleP:UI :: UI -> Process
$sel:titleP:UI :: UI -> Process
..} Observer{[Observer]
ObserverCoherent
spinner :: ObserverCoherent
background :: ObserverCoherent
messages :: [Observer]
$sel:spinner:Observer :: Observer -> ObserverCoherent
$sel:background:Observer :: Observer -> ObserverCoherent
$sel:messages:Observer :: Observer -> [Observer]
..} = do
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall env (m :: * -> *) source.
(MonadVulkan env m, HasOutput source,
 GetOutput source ~ Vector InstanceAttrs) =>
source -> Observer -> m ()
Message.observe) forall a b. (a -> b) -> a -> b
$
    forall a b. [a] -> [b] -> [(a, b)]
zip [Process
titleP, Process
subtitleP, Process
progressP] [Observer]
messages

  forall env (m :: * -> *) output bufs.
(MonadVulkan env m, HasOutput output,
 UpdateCoherent bufs (GetOutput output)) =>
output -> ObserverIO bufs -> m ()
Observer.observeCoherent Merge Stores
backgroundP ObserverCoherent
background
  forall env (m :: * -> *) output bufs.
(MonadVulkan env m, HasOutput output,
 UpdateCoherent bufs (GetOutput output)) =>
output -> ObserverIO bufs -> m ()
Observer.observeCoherent Merge Stores
spinnerP ObserverCoherent
spinner