keid-render-basic-0.1.8.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)
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
  { 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
  -> Layout.BoxProcess
  -> Settings fonts textures
  -> Engine.StageRIO env (Resource.ReleaseKey, UI)
spawn pools screenBoxP Settings{..} = Region.run do
  paddingVar <- Worker.newVar 16
  screenPaddedP <- Layout.padAbs screenBoxP paddingVar

  -- Messages

  sections <- Layout.splitsRelStatic Layout.sharePadsV screenPaddedP [2, 1, 1]

  (titleBoxP, subtitleBoxP, progressBoxP) <- case sections of
    [titleBoxP, subtitleBoxP, progressBoxP] ->
      pure (titleBoxP, subtitleBoxP, progressBoxP)
    _ ->
      error "assert: shares in Traversable preserve structure"

  titleP <- Worker.newVar title >>= Message.spawn titleBoxP
  subtitleP <- Worker.newVar subtitle >>= Message.spawn subtitleBoxP

  progressInput <- Worker.newVar progress
  progressP <- Message.spawn progressBoxP progressInput

  -- Splash

  backgroundBoxP <- Layout.fitPlaceAbs Layout.Center 1.0 screenBoxP

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

  -- Spinner

  spinnerTransformTimeP <-
    Worker.spawnTimed_ True 100 mempty do
      t <- getMonotonicTime
      pure $ Transform.rotateZ (realToFrac t)

  spinnerTransformBoxP <-
    Worker.spawnMerge1
      (Layout.boxTransformAbs . snd . Layout.boxFitScale 64)
      subtitleBoxP

  spinnerP <-
    Worker.spawnMerge2
      ( \place turn ->
          UnlitTextured.stores1
              (Samplers.linear Samplers.indices)
              spinnerIx
              [turn, place]
      )
      spinnerTransformBoxP
      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       = 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 :: 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