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
{ titleMessage :: Text
, backgroundIx :: Int32
, spinnerIx :: Int32
, combined :: CombinedTextures.Collection textures fonts (Int32, Texture Flat)
, fonts :: fonts EvanW.Container
, smallFont :: forall a . fonts a -> a
, largeFont :: forall a . fonts a -> a
}
data UI = UI
{ titleP :: Message.Process
, subtitleP :: Message.Process
, progressInput :: Worker.Var Message.Input
, progressP :: Message.Process
, backgroundP :: Worker.Merge StorableAttrs
, spinnerP :: Worker.Merge StorableAttrs
, 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 pools screenBoxP Settings{..} = do
paddingVar <- Worker.newVar 16
(screenPaddedKey, screenPaddedP) <- Worker.registered $
Layout.padAbs screenBoxP paddingVar
-- Messages
sections <- Layout.splitsRelStatic Layout.sharePadsV screenPaddedP [2, 1, 1]
sectionsKey <- Worker.registerCollection sections
(titleBoxP, subtitleBoxP, progressBoxP) <- case sections of
[titleBoxP, subtitleBoxP, progressBoxP] ->
pure (titleBoxP, subtitleBoxP, progressBoxP)
_ ->
error "assert: shares in Traversable preserve structure"
(titleKey, titleP) <- Worker.registered $
Worker.newVar title >>= Message.spawn titleBoxP
(subtitleKey, subtitleP) <- Worker.registered $
Worker.newVar subtitle >>= Message.spawn subtitleBoxP
progressInput <- Worker.newVar progress
(progressKey, progressP) <- Worker.registered $
Message.spawn progressBoxP progressInput
-- Splash
(backgroundBoxKey, backgroundBoxP) <- Worker.registered $
Layout.fitPlaceAbs Layout.Center 1.0 screenBoxP
(backgroundKey, backgroundP) <- Worker.registered $
Worker.spawnMerge1
( \box ->
UnlitTextured.storableAttrs1
(Samplers.linear Samplers.indices)
backgroundIx
[Layout.boxTransformAbs box]
)
backgroundBoxP
-- Spinner
(spinnerTransformTimeKey, spinnerTransformTimeP) <- Worker.registered $
Worker.spawnTimed_ True 100 mempty do
t <- getMonotonicTime
pure $ Transform.rotateZ (realToFrac t)
(spinnerTransformBoxKey, spinnerTransformBoxP) <- Worker.registered $
Worker.spawnMerge1
(Layout.boxTransformAbs . snd . Layout.boxFitScale 64)
subtitleBoxP
(spinnerKey, spinnerP) <- Worker.registered $
Worker.spawnMerge2
( \place turn ->
UnlitTextured.storableAttrs1
(Samplers.linear Samplers.indices)
spinnerIx
[turn, place]
)
spinnerTransformBoxP
spinnerTransformTimeP
-- Models
context <- ask
quadUV <- Model.createStagedL context pools (Quad.toVertices Quad.texturedQuad) Nothing
quadUVKey <- Resource.register $ Model.destroyIndexed context quadUV
-- Cleanup
key <- Resource.register $ traverse_ Resource.release
[ screenPaddedKey
, sectionsKey
, titleKey, subtitleKey, progressKey
, backgroundBoxKey, backgroundKey
, spinnerTransformBoxKey, spinnerTransformTimeKey, spinnerKey
, quadUVKey
]
pure (key, UI{..})
where
title = Message.Input
{ inputText = titleMessage
, inputOrigin = Layout.CenterBottom
, inputSize = 64
, inputColor = vec4 1 0.5 0.25 1
, inputFont = largeFont fonts
, inputFontId = fst . largeFont $ CombinedTextures.fonts combined
, inputOutline = vec4 0 0 0 1
, inputOutlineWidth = 4/16
, inputSmoothing = 1/16
}
subtitle = Message.Input
{ inputText = "Loading..."
, inputOrigin = Layout.CenterTop
, inputSize = 32
, inputColor = vec4 0.5 1 0.25 1
, inputFont = smallFont fonts
, inputFontId = fst . smallFont $ CombinedTextures.fonts combined
, inputOutline = vec4 0 0 0 1
, inputOutlineWidth = 4/16
, inputSmoothing = 1/16
}
progress = Message.Input
{ inputText = ""
, inputOrigin = Layout.CenterBottom
, inputSize = 16
, inputColor = vec4 0.25 0.5 1 1
, inputFont = smallFont fonts
, inputFontId = fst . smallFont $ CombinedTextures.fonts combined
, inputOutline = 0
, inputOutlineWidth = 0
, inputSmoothing = 1/16
}
data Observer = Observer
{ messages :: [Message.Observer]
, background :: Worker.ObserverIO (UnlitTextured.InstanceBuffers 'Buffer.Coherent 'Buffer.Coherent)
, spinner :: Worker.ObserverIO (UnlitTextured.InstanceBuffers 'Buffer.Coherent 'Buffer.Coherent)
}
newObserver :: UI -> ResourceT (Engine.StageRIO st) Observer
newObserver UI{..} = do
-- XXX: Generic?
messages <- traverse (const $ Message.newObserver 256)
[ titleP
, subtitleP
, progressP
]
let
newBufferObserver1 =
UnlitTextured.allocateInstancesCoherent_ 1 >>= Worker.newObserverIO
background <- newBufferObserver1
spinner <- newBufferObserver1
pure Observer{..}
observe
:: ( HasVulkan env
)
=> UI
-> Observer -> RIO env ()
observe UI{..} Observer{..} = do
traverse_ (uncurry Message.observe) $
zip [titleP, subtitleP, progressP] messages
context <- ask
Worker.observeIO_ backgroundP background $
UnlitTextured.updateCoherentResize_ context
Worker.observeIO_ spinnerP spinner $
UnlitTextured.updateCoherentResize_ context