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 RIO.Vector.Storable qualified as Storable
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.Texture (Texture, Flat)

data Settings fonts textures = Settings
  { Settings fonts textures -> Text
titleMessage :: Text
  , Settings fonts textures -> Int32
backgroundIx :: Int32
  , Settings fonts textures -> Int32
spinnerIx    :: Int32

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

  , Settings fonts textures -> forall a. fonts a -> a
smallFont    :: forall a . fonts a -> a
  , 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 StorableAttrs
backgroundP :: Worker.Merge StorableAttrs
  , UI -> Merge StorableAttrs
spinnerP    :: Worker.Merge StorableAttrs

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

type StorableAttrs =
  ( Storable.Vector UnlitTextured.TextureParams
  , Storable.Vector UnlitTextured.Transform
  )

spawn
  :: Queues Vk.CommandPool
  -> Layout.BoxProcess
  -> Settings fonts textures
  -> Engine.StageRIO env (Resource.ReleaseKey, UI)
spawn :: 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
..} = do
  Var Vec4
paddingVar <- Vec4 -> RIO (App GlobalHandles env) (Var Vec4)
forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Vec4
16
  (ReleaseKey
screenPaddedKey, BoxProcess
screenPaddedP) <- RIO (App GlobalHandles env) BoxProcess
-> RIO (App GlobalHandles env) (ReleaseKey, BoxProcess)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles env) BoxProcess
 -> RIO (App GlobalHandles env) (ReleaseKey, BoxProcess))
-> RIO (App GlobalHandles env) BoxProcess
-> RIO (App GlobalHandles env) (ReleaseKey, BoxProcess)
forall a b. (a -> b) -> a -> b
$
    BoxProcess -> Var Vec4 -> RIO (App GlobalHandles env) BoxProcess
forall (m :: * -> *) parent padding.
(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 <- ((Float, Float) -> Vec4)
-> BoxProcess
-> [Float]
-> RIO (App GlobalHandles env) [BoxProcess]
forall (m :: * -> *) parent (t :: * -> *).
(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]
  ReleaseKey
sectionsKey <- [BoxProcess] -> RIO (App GlobalHandles env) ReleaseKey
forall (m :: * -> *) process (t :: * -> *).
(MonadResource m, HasWorker process, Foldable t) =>
t process -> m ReleaseKey
Worker.registerCollection [BoxProcess]
sections

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

  (ReleaseKey
titleKey, Process
titleP) <- RIO (App GlobalHandles env) Process
-> RIO (App GlobalHandles env) (ReleaseKey, Process)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles env) Process
 -> RIO (App GlobalHandles env) (ReleaseKey, Process))
-> RIO (App GlobalHandles env) Process
-> RIO (App GlobalHandles env) (ReleaseKey, Process)
forall a b. (a -> b) -> a -> b
$
    Input -> RIO (App GlobalHandles env) (Var Input)
forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Input
title RIO (App GlobalHandles env) (Var Input)
-> (Var Input -> RIO (App GlobalHandles env) Process)
-> RIO (App GlobalHandles env) Process
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BoxProcess -> Var Input -> RIO (App GlobalHandles env) Process
forall box input env.
(HasOutput box, GetOutput box ~ Box, HasOutput input,
 GetOutput input ~ Input) =>
box -> input -> RIO env Process
Message.spawn BoxProcess
titleBoxP
  (ReleaseKey
subtitleKey, Process
subtitleP) <- RIO (App GlobalHandles env) Process
-> RIO (App GlobalHandles env) (ReleaseKey, Process)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles env) Process
 -> RIO (App GlobalHandles env) (ReleaseKey, Process))
-> RIO (App GlobalHandles env) Process
-> RIO (App GlobalHandles env) (ReleaseKey, Process)
forall a b. (a -> b) -> a -> b
$
    Input -> RIO (App GlobalHandles env) (Var Input)
forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Input
subtitle RIO (App GlobalHandles env) (Var Input)
-> (Var Input -> RIO (App GlobalHandles env) Process)
-> RIO (App GlobalHandles env) Process
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BoxProcess -> Var Input -> RIO (App GlobalHandles env) Process
forall box input env.
(HasOutput box, GetOutput box ~ Box, HasOutput input,
 GetOutput input ~ Input) =>
box -> input -> RIO env Process
Message.spawn BoxProcess
subtitleBoxP

  Var Input
progressInput <- Input -> RIO (App GlobalHandles env) (Var Input)
forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Input
progress
  (ReleaseKey
progressKey, Process
progressP) <- RIO (App GlobalHandles env) Process
-> RIO (App GlobalHandles env) (ReleaseKey, Process)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles env) Process
 -> RIO (App GlobalHandles env) (ReleaseKey, Process))
-> RIO (App GlobalHandles env) Process
-> RIO (App GlobalHandles env) (ReleaseKey, Process)
forall a b. (a -> b) -> a -> b
$
    BoxProcess -> Var Input -> RIO (App GlobalHandles env) Process
forall box input env.
(HasOutput box, GetOutput box ~ Box, HasOutput input,
 GetOutput input ~ Input) =>
box -> input -> RIO env Process
Message.spawn BoxProcess
progressBoxP Var Input
progressInput

  -- Splash

  (ReleaseKey
backgroundBoxKey, BoxProcess
backgroundBoxP) <- RIO (App GlobalHandles env) BoxProcess
-> RIO (App GlobalHandles env) (ReleaseKey, BoxProcess)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles env) BoxProcess
 -> RIO (App GlobalHandles env) (ReleaseKey, BoxProcess))
-> RIO (App GlobalHandles env) BoxProcess
-> RIO (App GlobalHandles env) (ReleaseKey, BoxProcess)
forall a b. (a -> b) -> a -> b
$
    Alignment
-> ("dimensions" ::: Vec2)
-> BoxProcess
-> RIO (App GlobalHandles env) BoxProcess
forall (m :: * -> *) parent.
(MonadUnliftIO m, HasOutput parent, GetOutput parent ~ Box) =>
Alignment -> ("dimensions" ::: Vec2) -> parent -> m BoxProcess
Layout.fitPlaceAbs Alignment
Layout.Center "dimensions" ::: Vec2
1.0 BoxProcess
screenBoxP

  (ReleaseKey
backgroundKey, Merge StorableAttrs
backgroundP) <- RIO (App GlobalHandles env) (Merge StorableAttrs)
-> RIO (App GlobalHandles env) (ReleaseKey, Merge StorableAttrs)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles env) (Merge StorableAttrs)
 -> RIO (App GlobalHandles env) (ReleaseKey, Merge StorableAttrs))
-> RIO (App GlobalHandles env) (Merge StorableAttrs)
-> RIO (App GlobalHandles env) (ReleaseKey, Merge StorableAttrs)
forall a b. (a -> b) -> a -> b
$
    (GetOutput BoxProcess -> StorableAttrs)
-> BoxProcess -> RIO (App GlobalHandles env) (Merge StorableAttrs)
forall (m :: * -> *) i o.
(MonadUnliftIO m, HasOutput i) =>
(GetOutput i -> o) -> i -> m (Merge o)
Worker.spawnMerge1
      ( \GetOutput BoxProcess
box ->
          Int32 -> Int32 -> [Transform] -> StorableAttrs
UnlitTextured.storableAttrs1
              (Collection Int32 -> Int32
forall a. Collection a -> a
Samplers.linear Collection Int32
Samplers.indices)
              Int32
backgroundIx
              [Box -> Transform
Layout.boxTransformAbs GetOutput BoxProcess
Box
box]
      )
      BoxProcess
backgroundBoxP

  -- Spinner

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

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

  (ReleaseKey
spinnerKey, Merge StorableAttrs
spinnerP) <- RIO (App GlobalHandles env) (Merge StorableAttrs)
-> RIO (App GlobalHandles env) (ReleaseKey, Merge StorableAttrs)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles env) (Merge StorableAttrs)
 -> RIO (App GlobalHandles env) (ReleaseKey, Merge StorableAttrs))
-> RIO (App GlobalHandles env) (Merge StorableAttrs)
-> RIO (App GlobalHandles env) (ReleaseKey, Merge StorableAttrs)
forall a b. (a -> b) -> a -> b
$
    (GetOutput (Merge Transform)
 -> GetOutput (Timed () Transform) -> StorableAttrs)
-> Merge Transform
-> Timed () Transform
-> RIO (App GlobalHandles env) (Merge StorableAttrs)
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO 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] -> StorableAttrs
UnlitTextured.storableAttrs1
              (Collection Int32 -> Int32
forall a. Collection a -> a
Samplers.linear Collection Int32
Samplers.indices)
              Int32
spinnerIx
              [Transform
GetOutput (Timed () Transform)
turn, Transform
GetOutput (Merge Transform)
place]
      )
      Merge Transform
spinnerTransformBoxP
      Timed () Transform
spinnerTransformTimeP

  -- Models

  App GlobalHandles env
context <- RIO (App GlobalHandles env) (App GlobalHandles env)
forall r (m :: * -> *). MonadReader r m => m r
ask
  Model 'Staged
quadUV <- App GlobalHandles env
-> Queues CommandPool
-> [Vertex Packed ("dimensions" ::: Vec2)]
-> Maybe [Word32]
-> RIO (App GlobalHandles env) (Model 'Staged)
forall context pos attrs (io :: * -> *).
(HasVulkan context, Storable pos, Storable attrs,
 MonadUnliftIO io) =>
context
-> Queues CommandPool
-> [Vertex pos attrs]
-> Maybe [Word32]
-> io (Indexed 'Staged pos attrs)
Model.createStagedL App GlobalHandles env
context Queues CommandPool
pools (Quad (Vertex Packed ("dimensions" ::: Vec2))
-> [Vertex Packed ("dimensions" ::: Vec2)]
forall pos attrs. Quad (Vertex pos attrs) -> [Vertex pos attrs]
Quad.toVertices Quad (Vertex Packed ("dimensions" ::: Vec2))
Quad.texturedQuad) Maybe [Word32]
forall a. Maybe a
Nothing
  ReleaseKey
quadUVKey <- IO () -> RIO (App GlobalHandles env) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> RIO (App GlobalHandles env) ReleaseKey)
-> IO () -> RIO (App GlobalHandles env) ReleaseKey
forall a b. (a -> b) -> a -> b
$ App GlobalHandles env -> Model 'Staged -> IO ()
forall context (io :: * -> *) (storage :: Store) pos attrs.
(HasVulkan context, MonadUnliftIO io) =>
context -> Indexed storage pos attrs -> io ()
Model.destroyIndexed App GlobalHandles env
context Model 'Staged
quadUV

  -- Cleanup

  ReleaseKey
key <- IO () -> RIO (App GlobalHandles env) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> RIO (App GlobalHandles env) ReleaseKey)
-> IO () -> RIO (App GlobalHandles env) ReleaseKey
forall a b. (a -> b) -> a -> b
$ (ReleaseKey -> IO ()) -> [ReleaseKey] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release
    [ ReleaseKey
screenPaddedKey
    , ReleaseKey
sectionsKey
    , ReleaseKey
titleKey, ReleaseKey
subtitleKey, ReleaseKey
progressKey
    , ReleaseKey
backgroundBoxKey, ReleaseKey
backgroundKey
    , ReleaseKey
spinnerTransformBoxKey, ReleaseKey
spinnerTransformTimeKey, ReleaseKey
spinnerKey
    , ReleaseKey
quadUVKey
    ]

  pure (ReleaseKey
key, UI :: Process
-> Process
-> Var Input
-> Process
-> Merge StorableAttrs
-> Merge StorableAttrs
-> Model 'Staged
-> UI
UI{Var Input
Model 'Staged
Merge StorableAttrs
Process
quadUV :: Model 'Staged
spinnerP :: Merge StorableAttrs
backgroundP :: Merge StorableAttrs
progressP :: Process
progressInput :: Var Input
subtitleP :: Process
titleP :: Process
$sel:quadUV:UI :: Model 'Staged
$sel:spinnerP:UI :: Merge StorableAttrs
$sel:backgroundP:UI :: Merge StorableAttrs
$sel:progressP:UI :: Process
$sel:progressInput:UI :: Var Input
$sel:subtitleP:UI :: Process
$sel:titleP:UI :: Process
..})
  where
    title :: Input
title = Input :: Text
-> Int32
-> Container
-> Alignment
-> Float
-> Vec4
-> Vec4
-> Float
-> Float
-> Input
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         = fonts Container -> Container
forall a. fonts a -> a
largeFont fonts Container
fonts
      , $sel:inputFontId:Input :: Int32
inputFontId       = (Int32, Texture Flat) -> Int32
forall a b. (a, b) -> a
fst ((Int32, Texture Flat) -> Int32)
-> (fonts (Int32, Texture Flat) -> (Int32, Texture Flat))
-> fonts (Int32, Texture Flat)
-> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. fonts (Int32, Texture Flat) -> (Int32, Texture Flat)
forall a. fonts a -> a
largeFont (fonts (Int32, Texture Flat) -> Int32)
-> fonts (Int32, Texture Flat) -> Int32
forall a b. (a -> b) -> a -> b
$ Collection textures fonts (Int32, Texture Flat)
-> fonts (Int32, Texture Flat)
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
4Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
16
      , $sel:inputSmoothing:Input :: Float
inputSmoothing    = Float
1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
16
      }

    subtitle :: Input
subtitle = Input :: Text
-> Int32
-> Container
-> Alignment
-> Float
-> Vec4
-> Vec4
-> Float
-> Float
-> Input
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         = fonts Container -> Container
forall a. fonts a -> a
smallFont fonts Container
fonts
      , $sel:inputFontId:Input :: Int32
inputFontId       = (Int32, Texture Flat) -> Int32
forall a b. (a, b) -> a
fst ((Int32, Texture Flat) -> Int32)
-> (fonts (Int32, Texture Flat) -> (Int32, Texture Flat))
-> fonts (Int32, Texture Flat)
-> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. fonts (Int32, Texture Flat) -> (Int32, Texture Flat)
forall a. fonts a -> a
smallFont (fonts (Int32, Texture Flat) -> Int32)
-> fonts (Int32, Texture Flat) -> Int32
forall a b. (a -> b) -> a -> b
$ Collection textures fonts (Int32, Texture Flat)
-> fonts (Int32, Texture Flat)
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
4Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
16
      , $sel:inputSmoothing:Input :: Float
inputSmoothing    = Float
1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
16
      }

    progress :: Input
progress = Input :: Text
-> Int32
-> Container
-> Alignment
-> Float
-> Vec4
-> Vec4
-> Float
-> Float
-> Input
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         = fonts Container -> Container
forall a. fonts a -> a
smallFont fonts Container
fonts
      , $sel:inputFontId:Input :: Int32
inputFontId       = (Int32, Texture Flat) -> Int32
forall a b. (a, b) -> a
fst ((Int32, Texture Flat) -> Int32)
-> (fonts (Int32, Texture Flat) -> (Int32, Texture Flat))
-> fonts (Int32, Texture Flat)
-> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. fonts (Int32, Texture Flat) -> (Int32, Texture Flat)
forall a. fonts a -> a
smallFont (fonts (Int32, Texture Flat) -> Int32)
-> fonts (Int32, Texture Flat) -> Int32
forall a b. (a -> b) -> a -> b
$ Collection textures fonts (Int32, Texture Flat)
-> fonts (Int32, Texture Flat)
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
1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
16
      }

data Observer = Observer
  { Observer -> [Observer]
messages   :: [Message.Observer]
  , Observer -> ObserverIO (InstanceBuffers 'Coherent 'Coherent)
background :: Worker.ObserverIO (UnlitTextured.InstanceBuffers 'Buffer.Coherent 'Buffer.Coherent)
  , Observer -> ObserverIO (InstanceBuffers 'Coherent 'Coherent)
spinner    :: Worker.ObserverIO (UnlitTextured.InstanceBuffers 'Buffer.Coherent 'Buffer.Coherent)
  }

newObserver :: UI -> ResourceT (Engine.StageRIO st) Observer
newObserver :: UI -> ResourceT (StageRIO st) Observer
newObserver UI{Var Input
Model 'Staged
Merge StorableAttrs
Process
quadUV :: Model 'Staged
spinnerP :: Merge StorableAttrs
backgroundP :: Merge StorableAttrs
progressP :: Process
progressInput :: Var Input
subtitleP :: Process
titleP :: Process
$sel:quadUV:UI :: UI -> Model 'Staged
$sel:spinnerP:UI :: UI -> Merge StorableAttrs
$sel:backgroundP:UI :: UI -> Merge StorableAttrs
$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 <- (Process -> ResourceT (StageRIO st) Observer)
-> [Process] -> ResourceT (StageRIO st) [Observer]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ResourceT (StageRIO st) Observer
-> Process -> ResourceT (StageRIO st) Observer
forall a b. a -> b -> a
const (ResourceT (StageRIO st) Observer
 -> Process -> ResourceT (StageRIO st) Observer)
-> ResourceT (StageRIO st) Observer
-> Process
-> ResourceT (StageRIO st) Observer
forall a b. (a -> b) -> a -> b
$ Int -> ResourceT (StageRIO st) Observer
forall st. Int -> ResourceT (StageRIO st) Observer
Message.newObserver Int
256)
    [ Process
titleP
    , Process
subtitleP
    , Process
progressP
    ]

  let
    newBufferObserver1 :: ResourceT
  (StageRIO st) (ObserverIO (InstanceBuffers 'Coherent 'Coherent))
newBufferObserver1 =
      Int
-> ResourceT (StageRIO st) (InstanceBuffers 'Coherent 'Coherent)
forall env.
HasVulkan env =>
Int -> ResourceT (RIO env) (InstanceBuffers 'Coherent 'Coherent)
UnlitTextured.allocateInstancesCoherent_ Int
1 ResourceT (StageRIO st) (InstanceBuffers 'Coherent 'Coherent)
-> (InstanceBuffers 'Coherent 'Coherent
    -> ResourceT
         (StageRIO st) (ObserverIO (InstanceBuffers 'Coherent 'Coherent)))
-> ResourceT
     (StageRIO st) (ObserverIO (InstanceBuffers 'Coherent 'Coherent))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstanceBuffers 'Coherent 'Coherent
-> ResourceT
     (StageRIO st) (ObserverIO (InstanceBuffers 'Coherent 'Coherent))
forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO

  ObserverIO (InstanceBuffers 'Coherent 'Coherent)
background <- ResourceT
  (StageRIO st) (ObserverIO (InstanceBuffers 'Coherent 'Coherent))
newBufferObserver1
  ObserverIO (InstanceBuffers 'Coherent 'Coherent)
spinner <- ResourceT
  (StageRIO st) (ObserverIO (InstanceBuffers 'Coherent 'Coherent))
newBufferObserver1

  pure Observer :: [Observer]
-> ObserverIO (InstanceBuffers 'Coherent 'Coherent)
-> ObserverIO (InstanceBuffers 'Coherent 'Coherent)
-> Observer
Observer{[Observer]
ObserverIO (InstanceBuffers 'Coherent 'Coherent)
spinner :: ObserverIO (InstanceBuffers 'Coherent 'Coherent)
background :: ObserverIO (InstanceBuffers 'Coherent 'Coherent)
messages :: [Observer]
$sel:spinner:Observer :: ObserverIO (InstanceBuffers 'Coherent 'Coherent)
$sel:background:Observer :: ObserverIO (InstanceBuffers 'Coherent 'Coherent)
$sel:messages:Observer :: [Observer]
..}

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

  env
context <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask

  Merge StorableAttrs
-> ObserverIO (InstanceBuffers 'Coherent 'Coherent)
-> (InstanceBuffers 'Coherent 'Coherent
    -> GetOutput (Merge StorableAttrs)
    -> RIO env (InstanceBuffers 'Coherent 'Coherent))
-> RIO env ()
forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m ()
Worker.observeIO_ Merge StorableAttrs
backgroundP ObserverIO (InstanceBuffers 'Coherent 'Coherent)
background ((InstanceBuffers 'Coherent 'Coherent
  -> GetOutput (Merge StorableAttrs)
  -> RIO env (InstanceBuffers 'Coherent 'Coherent))
 -> RIO env ())
-> (InstanceBuffers 'Coherent 'Coherent
    -> GetOutput (Merge StorableAttrs)
    -> RIO env (InstanceBuffers 'Coherent 'Coherent))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
    env
-> InstanceBuffers 'Coherent 'Coherent
-> StorableAttrs
-> RIO env (InstanceBuffers 'Coherent 'Coherent)
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> InstanceBuffers 'Coherent 'Coherent
-> StorableAttrs
-> m (InstanceBuffers 'Coherent 'Coherent)
UnlitTextured.updateCoherentResize_ env
context

  Merge StorableAttrs
-> ObserverIO (InstanceBuffers 'Coherent 'Coherent)
-> (InstanceBuffers 'Coherent 'Coherent
    -> GetOutput (Merge StorableAttrs)
    -> RIO env (InstanceBuffers 'Coherent 'Coherent))
-> RIO env ()
forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m ()
Worker.observeIO_ Merge StorableAttrs
spinnerP ObserverIO (InstanceBuffers 'Coherent 'Coherent)
spinner ((InstanceBuffers 'Coherent 'Coherent
  -> GetOutput (Merge StorableAttrs)
  -> RIO env (InstanceBuffers 'Coherent 'Coherent))
 -> RIO env ())
-> (InstanceBuffers 'Coherent 'Coherent
    -> GetOutput (Merge StorableAttrs)
    -> RIO env (InstanceBuffers 'Coherent 'Coherent))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
    env
-> InstanceBuffers 'Coherent 'Coherent
-> StorableAttrs
-> RIO env (InstanceBuffers 'Coherent 'Coherent)
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> InstanceBuffers 'Coherent 'Coherent
-> StorableAttrs
-> m (InstanceBuffers 'Coherent 'Coherent)
UnlitTextured.updateCoherentResize_ env
context