keid-render-basic-0.1.10.0: src/Stage/Loader/UI.hs

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, withVec2)
import Geomancy.Layout qualified as Layout
import Geomancy.Layout.Alignment qualified as Alignment
import Geomancy.Layout.Box qualified as Box
import Geomancy.Transform qualified as Transform
import Vulkan.Core10 qualified as Vk

import Engine.Camera qualified as Camera
import Engine.Types qualified as Engine
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
  { 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 UnlitTextured.Stores
  , spinnerP    :: Worker.Merge UnlitTextured.Stores

  , quadUV :: UnlitTextured.Model 'Buffer.Staged
  }

spawn
  :: Queues Vk.CommandPool
  -> Settings fonts textures
  -> Engine.StageRIO env (Resource.ReleaseKey, UI)
spawn pools Settings{..} = Region.run do
  screenBoxP <- Camera.trackOrthoPixelsCentered

  screenPaddedP <-
    Worker.spawnMerge1
      (Box.resize (-16))
      screenBoxP

  -- Messages

  sectionsP <-
    Worker.spawnMerge1
      ( \parent ->
          let
            (top, bottom) = Layout.vertical (Right 0.5) parent
          in
            ( top
            , Layout.vertical (Right 0.5) bottom
            )
      )
      screenPaddedP

  titleBoxP <- Worker.spawnMerge1 fst sectionsP
  titleP <- Worker.newVar title >>= Message.spawn titleBoxP

  lowerSectionP <- Worker.spawnMerge1 snd sectionsP

  subtitleBoxP <- Worker.spawnMerge1 fst lowerSectionP
  subtitleP <- Worker.newVar subtitle >>= Message.spawn subtitleBoxP

  progressInput <- Worker.newVar progress
  progressBoxP <- Worker.spawnMerge1 snd lowerSectionP
  progressP <- Message.spawn progressBoxP progressInput

  -- Splash

  backgroundBoxP <-
    Worker.spawnMerge1
      (Layout.placeAspect Alignment.center 1)
      screenBoxP

  backgroundP <-
    Worker.spawnMerge1
      ( \box ->
          UnlitTextured.stores1
              (Samplers.linear Samplers.indices)
              backgroundIx
              [Box.mkTransform box]
      )
      backgroundBoxP

  -- Spinner

  spinnerTransformTimeP <-
    Worker.spawnTimed_ True 100 0.0 Engine.secondsSinceStart

  spinnerP <-
    Worker.spawnMerge2
      ( \box time ->
          withVec2 box.position \x y ->
            withVec2 box.size \w h ->
            UnlitTextured.stores1
              (Samplers.linear Samplers.indices)
              spinnerIx
              [ Transform.translate x y 0
              , Transform.rotateZ time
              , Transform.scale (min 256 $ min w h)
              ]
      )
      subtitleBoxP
      spinnerTransformTimeP

  -- Models

  quadUV <- Model.createStagedL
    (Just "quadUV")
    pools
    (Quad.toVertices Quad.texturedQuad)
    Nothing
  Model.registerIndexed_ quadUV

  pure UI{..}
  where
    title = Message.Input
      { inputText         = titleMessage
      , inputOrigin       = Alignment.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       = Alignment.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       = Alignment.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 :: UnlitTextured.ObserverCoherent
  , spinner    :: UnlitTextured.ObserverCoherent
  }

newObserver :: UI -> ResourceT (Engine.StageRIO st) Observer
newObserver UI{..} = do
  -- XXX: Generic?
  messages <- traverse (const $ Message.newObserver 256)
    [ titleP
    , subtitleP
    , progressP
    ]

  background <- Observer.newCoherent 1 "background"
  spinner <- Observer.newCoherent 1 "spinner"

  pure Observer{..}

observe
  :: ( HasVulkan env
     )
  => UI
  -> Observer -> RIO env ()
observe UI{..} Observer{..} = do
  traverse_ (uncurry Message.observe) $
    zip [titleP, subtitleP, progressP] messages

  Observer.observeCoherent backgroundP background
  Observer.observeCoherent spinnerP spinner