{-# LANGUAGE PatternSynonyms #-}
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 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
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
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
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
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)