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