{-# LANGUAGE PatternSynonyms #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.TUI.Controller.Util where

import Brick hiding (Direction)
import Brick.Focus
import Control.Lens
import Control.Monad (forM_, unless)
import Control.Monad.IO.Class (liftIO)
import Data.Map qualified as M
import Graphics.Vty qualified as V
import Swarm.Game.State
import Swarm.Game.Universe
import Swarm.Game.World qualified as W
import Swarm.TUI.Model
import Swarm.TUI.Model.UI
import Swarm.TUI.View.Util (generateModal)

-- | Pattern synonyms to simplify brick event handler
pattern Key :: V.Key -> BrickEvent n e
pattern $bKey :: forall n e. Key -> BrickEvent n e
$mKey :: forall {r} {n} {e}.
BrickEvent n e -> (Key -> r) -> ((# #) -> r) -> r
Key k = VtyEvent (V.EvKey k [])

pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e
pattern $bCharKey :: forall n e. Char -> BrickEvent n e
$mCharKey :: forall {r} {n} {e}.
BrickEvent n e -> (Char -> r) -> ((# #) -> r) -> r
CharKey c = VtyEvent (V.EvKey (V.KChar c) [])
pattern $bControlChar :: forall n e. Char -> BrickEvent n e
$mControlChar :: forall {r} {n} {e}.
BrickEvent n e -> (Char -> r) -> ((# #) -> r) -> r
ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl])
pattern $bMetaChar :: forall n e. Char -> BrickEvent n e
$mMetaChar :: forall {r} {n} {e}.
BrickEvent n e -> (Char -> r) -> ((# #) -> r) -> r
MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta])

pattern ShiftKey :: V.Key -> BrickEvent n e
pattern $bShiftKey :: forall n e. Key -> BrickEvent n e
$mShiftKey :: forall {r} {n} {e}.
BrickEvent n e -> (Key -> r) -> ((# #) -> r) -> r
ShiftKey k = VtyEvent (V.EvKey k [V.MShift])

pattern EscapeKey :: BrickEvent n e
pattern $bEscapeKey :: forall n e. BrickEvent n e
$mEscapeKey :: forall {r} {n} {e}.
BrickEvent n e -> ((# #) -> r) -> ((# #) -> r) -> r
EscapeKey = VtyEvent (V.EvKey V.KEsc [])

pattern BackspaceKey :: BrickEvent n e
pattern $bBackspaceKey :: forall n e. BrickEvent n e
$mBackspaceKey :: forall {r} {n} {e}.
BrickEvent n e -> ((# #) -> r) -> ((# #) -> r) -> r
BackspaceKey = VtyEvent (V.EvKey V.KBS [])

pattern FKey :: Int -> BrickEvent n e
pattern $bFKey :: forall n e. Int -> BrickEvent n e
$mFKey :: forall {r} {n} {e}.
BrickEvent n e -> (Int -> r) -> ((# #) -> r) -> r
FKey c = VtyEvent (V.EvKey (V.KFun c) [])

openModal :: ModalType -> EventM Name AppState ()
openModal :: ModalType -> EventM Name AppState ()
openModal ModalType
mt = do
  Modal
newModal <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip AppState -> ModalType -> Modal
generateModal ModalType
mt
  EventM Name AppState ()
ensurePause
  Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState (Maybe Modal)
uiModal forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= Modal
newModal
  -- Beep
  case ModalType
mt of
    ScenarioEndModal ScenarioOutcome
_ -> do
      Vty
vty <- forall n s. EventM n s Vty
getVtyHandle
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Output -> IO ()
V.ringTerminalBell forall a b. (a -> b) -> a -> b
$ Vty -> Output
V.outputIface Vty
vty
    ModalType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
  -- Set the game to AutoPause if needed
  ensurePause :: EventM Name AppState ()
ensurePause = do
    Bool
pause <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getter TemporalState Bool
paused
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
pause Bool -> Bool -> Bool
|| ModalType -> Bool
isRunningModal ModalType
mt) forall a b. (a -> b) -> a -> b
$ do
      Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState RunStatus
runStatus forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= RunStatus
AutoPause

-- | The running modals do not autopause the game.
isRunningModal :: ModalType -> Bool
isRunningModal :: ModalType -> Bool
isRunningModal = \case
  ModalType
RobotsModal -> Bool
True
  ModalType
MessagesModal -> Bool
True
  ModalType
_ -> Bool
False

setFocus :: FocusablePanel -> EventM Name AppState ()
setFocus :: FocusablePanel -> EventM Name AppState ()
setFocus FocusablePanel
name = Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState (FocusRing Name)
uiFocusRing forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall n. Eq n => n -> FocusRing n -> FocusRing n
focusSetCurrent (FocusablePanel -> Name
FocusablePanel FocusablePanel
name)

immediatelyRedrawWorld :: EventM Name AppState ()
immediatelyRedrawWorld :: EventM Name AppState ()
immediatelyRedrawWorld = do
  forall n s. Ord n => n -> EventM n s ()
invalidateCacheEntry Name
WorldCache
  EventM Name AppState ()
loadVisibleRegion

-- | Make sure all tiles covering the visible part of the world are
--   loaded.
loadVisibleRegion :: EventM Name AppState ()
loadVisibleRegion :: EventM Name AppState ()
loadVisibleRegion = do
  Maybe (Extent Name)
mext <- forall n s. Eq n => n -> EventM n s (Maybe (Extent n))
lookupExtent Name
WorldExtent
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Extent Name)
mext forall a b. (a -> b) -> a -> b
$ \(Extent Name
_ Location
_ (Int, Int)
size) -> do
    GameState
gs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' AppState GameState
gameState
    let vr :: Cosmic (Coords, Coords)
vr = Cosmic Location -> (Int32, Int32) -> Cosmic (Coords, Coords)
viewingRegion (GameState
gs forall s a. s -> Getting a s a -> a
^. Getter GameState (Cosmic Location)
viewCenter) (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int, Int)
size)
    Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape (MultiWorld Int Entity)
multiWorld forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (forall t e.
IArray UArray t =>
(Coords, Coords) -> World t e -> World t e
W.loadRegion (Cosmic (Coords, Coords)
vr forall s a. s -> Getting a s a -> a
^. forall a1 a2. Lens (Cosmic a1) (Cosmic a2) a1 a2
planar)) (Cosmic (Coords, Coords)
vr forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Cosmic a) SubworldName
subworld)

mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe (Cosmic W.Coords))
mouseLocToWorldCoords :: Location -> EventM Name GameState (Maybe (Cosmic Coords))
mouseLocToWorldCoords (Brick.Location (Int, Int)
mouseLoc) = do
  Maybe (Extent Name)
mext <- forall n s. Eq n => n -> EventM n s (Maybe (Extent n))
lookupExtent Name
WorldExtent
  case Maybe (Extent Name)
mext of
    Maybe (Extent Name)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just Extent Name
ext -> do
      Cosmic (Coords, Coords)
region <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Cosmic Location -> (Int32, Int32) -> Cosmic (Coords, Coords)
viewingRegion (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall n. Extent n -> (Int, Int)
extentSize Extent Name
ext)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getter GameState (Cosmic Location)
viewCenter
      let regionStart :: (Int32, Int32)
regionStart = Coords -> (Int32, Int32)
W.unCoords (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Cosmic (Coords, Coords)
region forall s a. s -> Getting a s a -> a
^. forall a1 a2. Lens (Cosmic a1) (Cosmic a2) a1 a2
planar)
          mouseLoc' :: (Int32, Int32)
mouseLoc' = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int, Int)
mouseLoc
          mx :: Int32
mx = forall a b. (a, b) -> b
snd (Int32, Int32)
mouseLoc' forall a. Num a => a -> a -> a
+ forall a b. (a, b) -> a
fst (Int32, Int32)
regionStart
          my :: Int32
my = forall a b. (a, b) -> a
fst (Int32, Int32)
mouseLoc' forall a. Num a => a -> a -> a
+ forall a b. (a, b) -> b
snd (Int32, Int32)
regionStart
       in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. SubworldName -> a -> Cosmic a
Cosmic (Cosmic (Coords, Coords)
region forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Cosmic a) SubworldName
subworld) forall a b. (a -> b) -> a -> b
$ (Int32, Int32) -> Coords
W.Coords (Int32
mx, Int32
my)