Skip to content

Commit

Permalink
simplify modal handling
Browse files Browse the repository at this point in the history 
... also Cleanup

- Remove dead code and use new col width
- Derive show instead of custom instance
- Apply wider text format
- Remove superfluous payload for splash
  • Loading branch information
@grancalavera
grancalavera committed Jun 16, 2019
1 parent 2c14364 commit a2d1964
Show file tree
Hide file tree
Showing 11 changed files with 182 additions and 307 deletions.
54 changes: 25 additions & 29 deletions app/Main.hs
View file
Original file line number Diff line number Diff line change
@@ -1,14 +1,14 @@
module Main where

import Brick
import Graphics.Vty ( Vty )
import Graphics.Vty ( Vty )
import qualified Graphics.Vty as V
import Control.Lens ( (^.) )
import Data.Maybe ( fromMaybe )
import Control.Lens ( (^.) )
import Data.Maybe ( fromMaybe )

import qualified Labyrinth.UI as UI
import qualified Labyrinth.UI.Widget as UI
import Labyrinth.UI ( Name )
import Labyrinth.UI ( Name )

import qualified Labyrinth.UI.Debug as Debug

Expand All @@ -22,10 +22,10 @@ import qualified Labyrinth.UI.Screen.Setup as Setup
import qualified Labyrinth.Store.Event.Setup as Setup

import qualified Labyrinth.Store as Store
import Labyrinth.Store ( Store
, State(..)
, Ev
)
import Labyrinth.Store ( Store
, State(..)
, Ev
)

main :: IO ()
main = do
Expand All @@ -41,24 +41,21 @@ app = App { appDraw = draw
}

draw :: Store e -> [Widget Name]
draw store =
[Debug.draw store, maybe drawScreen Modal.draw (Store.nextModal store)]
draw store = [Debug.draw store, maybe drawScreen Modal.draw (Store.nextModal store)]
where
drawScreen = UI.appContainer 50 $ case store ^. Store.state of
Splash s -> Splash.draw s
Setup s -> Setup.draw s
_ -> txt "Screen not implemented"
Splash -> Splash.draw
Setup s -> Setup.draw s
_ -> txt "Screen not implemented"

handleEvent
:: Ord e => Store e -> BrickEvent Name e -> EventM Name (Next (Store e))
handleEvent store ev = handle store ev
where
handle = if Store.isModalEvent store ev
then Modal.handle
else case store ^. Store.state of
Splash s -> Splash.handle s
Setup s -> Setup.handle s
_ -> \_ _ -> halt store
handleEvent :: Store e -> BrickEvent Name e -> EventM Name (Next (Store e))
handleEvent store (VtyEvent (V.EvKey (V.KChar 'q') [V.MCtrl])) = Modal.promptToQuit store
handleEvent store ev
| Store.isShowingModal store = Modal.handle store ev
| otherwise = case store ^. Store.state of
Splash -> Splash.handle () store ev
Setup s -> Setup.handle s store ev
_ -> halt store

buildVty :: IO Vty
buildVty = do
Expand All @@ -67,9 +64,8 @@ buildVty = do
return v

chooseCursor :: Store e -> [CursorLocation Name] -> Maybe (CursorLocation Name)
chooseCursor store =
fromMaybe (neverShowCursor store) $ if Store.isShowingModal store
then Store.nextModal store >>= Modal.chooseCursor
else case store ^. Store.state of
Setup s -> Setup.chooseCursor s
_ -> Nothing
chooseCursor store = fromMaybe (neverShowCursor store) $ if Store.isShowingModal store
then Store.nextModal store >>= Modal.chooseCursor
else case store ^. Store.state of
Setup s -> Setup.chooseCursor s
_ -> Nothing
170 changes: 46 additions & 124 deletions lib/Labyrinth/Game/Builder.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,6 @@ module Labyrinth.Game.Builder
( BuildTile(..)
, BuildPlan(..)
, BuildError(..)
, gameBuilder
, mkPlayers
, mkTreasures
, validatePlan
Expand All @@ -20,38 +19,29 @@ module Labyrinth.Game.Builder
)
where

import Linear.V2 ( V2(..) )
import Data.List.NonEmpty ( NonEmpty )
import Linear.V2 ( V2(..) )
import Data.List.NonEmpty ( NonEmpty )
import qualified Data.List.NonEmpty as NonEmpty
import Data.Bifunctor ( bimap )
import System.Random ( getStdGen )

import Control.Monad.IO.Class ( MonadIO
, liftIO
)
import Control.Monad.Except ( ExceptT
, liftEither
)
import Control.Lens ( makeLensesFor
, (#)
)
import Data.Validation ( Validate
, validate
, _Success
, _Failure
)

import Labyrinth.Game.Class ( Game )
import Labyrinth.Game.Direction ( Direction(..) )
import Data.Bifunctor ( bimap )
import Control.Lens ( makeLensesFor
, (#)
)
import Data.Validation ( Validate
, validate
, _Success
, _Failure
)

import Labyrinth.Game.Direction ( Direction(..) )
import qualified Labyrinth.Game.Player as Player
import Labyrinth.Game.Player ( PlayOrder(..)
, Players
)
import Labyrinth.Game.Position ( Position )
import Labyrinth.Game.Cell ( GateState(..)
, Cell(..)
, Terrain(..)
)
import Labyrinth.Game.Player ( PlayOrder(..)
, Players
)
import Labyrinth.Game.Position ( Position )
import Labyrinth.Game.Cell ( GateState(..)
, Cell(..)
, Terrain(..)
)

{-
- Take a blank board of dimensions 9x9
Expand Down Expand Up @@ -91,24 +81,7 @@ data BuildError = InvalidMinPlayers Int
| TooFewPositions
| TooManyTreasures
| TooFewTreasures
deriving Eq

instance Show BuildError where
show e = case e of
InvalidMinPlayers n -> "Error: minPlayers should be at least " <> show n
DuplicatedPositions ->
"Error: buildPositions should not have duplicated positions"
DuplicatedGatePositions -> "Error: all gates should have unique positions"
UnknownTilePosition p ->
"Error: a tile position must exist in buildPositions, unknown position: "
<> show p
InvalidBuildTreasures n ->
"Error: buildTreasures should be a multiple of " <> show n
TooManyPositions -> "Error: too many positions given"
TooFewPositions -> "Error: too few positions given"
TooManyTreasures -> "Error: too many treasures given"
TooFewTreasures -> "Error: too few treasures given"

deriving (Eq, Show)

data BuildTile = BuildHome Position Direction PlayOrder
| BuildFixedTreasureFork Position Direction
Expand All @@ -135,22 +108,7 @@ makeLensesFor
, ("minPlayers", "_minPlayers")
] ''BuildPlan


type GameBuilder m a = ExceptT [BuildError] m a

gameBuilder :: MonadIO m => BuildPlan -> GameBuilder m ([Int], Players)
gameBuilder plan = do
gen <- liftIO getStdGen
liftEither $ do
validatePlan plan
t <- mkTreasures plan
p <- mkPlayers plan
return (t, p)

validatePlan
:: (Validate f, Applicative (f [BuildError]))
=> BuildPlan
-> f [BuildError] ()
validatePlan :: (Validate f, Applicative (f [BuildError])) => BuildPlan -> f [BuildError] ()
validatePlan plan =
()
<$ validateFixedTilesPositions plan
Expand All @@ -159,77 +117,46 @@ validatePlan plan =
<* validateUniquePositions plan

validateFixedTilesPositions
:: (Validate f, Applicative (f [BuildError]))
=> BuildPlan
-> f [BuildError] ()
:: (Validate f, Applicative (f [BuildError])) => BuildPlan -> f [BuildError] ()
validateFixedTilesPositions BuildPlan { buildPositions, buildBoard } =
() <$ traverse (validateTilePosition buildPositions) buildBoard

validatePositionsCount
:: (Validate f, Applicative (f [BuildError]))
=> BuildPlan
-> f [BuildError] ()
:: (Validate f, Applicative (f [BuildError])) => BuildPlan -> f [BuildError] ()
validatePositionsCount BuildPlan { buildBoard, buildPositions } =
()
<$ validateSameLength TooFewPositions
TooManyPositions
buildBoard
buildPositions
() <$ validateSameLength TooFewPositions TooManyPositions buildBoard buildPositions

validateUniqueGatePositions
:: (Validate f, Applicative (f [BuildError]))
=> BuildPlan
-> f [BuildError] ()
:: (Validate f, Applicative (f [BuildError])) => BuildPlan -> f [BuildError] ()
validateUniqueGatePositions BuildPlan { buildGates } =
()
<$ validate [DuplicatedGatePositions]
(hasUniqueElements . fmap fst)
buildGates
() <$ validate [DuplicatedGatePositions] (hasUniqueElements . fmap fst) buildGates

mkPlayers :: Validate f => BuildPlan -> f [BuildError] Players
mkPlayers BuildPlan { minPlayers, buildPlayers } = validate
[InvalidMinPlayers minPlayers]
((minPlayers <=) . Player.count)
buildPlayers
mkPlayers BuildPlan { minPlayers, buildPlayers } =
validate [InvalidMinPlayers minPlayers] ((minPlayers <=) . Player.count) buildPlayers

mkTreasures
:: (Validate f, Applicative (f [BuildError]))
=> BuildPlan
-> f [BuildError] [Int]
mkTreasures plan@BuildPlan { buildTreasures } =
[1 .. buildTreasures] <$ validateTreasures plan
mkTreasures :: (Validate f, Applicative (f [BuildError])) => BuildPlan -> f [BuildError] [Int]
mkTreasures plan@BuildPlan { buildTreasures } = [1 .. buildTreasures] <$ validateTreasures plan

validateUniquePositions
:: (Validate f, Applicative (f [BuildError]))
=> BuildPlan
-> f [BuildError] ()
:: (Validate f, Applicative (f [BuildError])) => BuildPlan -> f [BuildError] ()
validateUniquePositions BuildPlan { buildPositions } =
() <$ validate [DuplicatedPositions] hasUniqueElements buildPositions

validateTreasures
:: (Validate f, Applicative (f [BuildError]))
=> BuildPlan
-> f [BuildError] ()
validateTreasures :: (Validate f, Applicative (f [BuildError])) => BuildPlan -> f [BuildError] ()
validateTreasures plan@BuildPlan { buildBoard, buildTreasures } =
()
<$ validateTreasurePlayerRatio plan buildTreasures
<* validateSameLength TooFewTreasures
TooManyTreasures
wantsTreasure
treasures
<* validateSameLength TooFewTreasures TooManyTreasures wantsTreasure treasures
where
treasures = [1 .. buildTreasures]
wantsTreasure = NonEmpty.filter hasTreasure buildBoard

validateTreasurePlayerRatio
:: Validate f => BuildPlan -> Int -> f [BuildError] ()
validateTreasurePlayerRatio plan buildTreasures =
either (_Failure #) (_Success #) $ do
pCount <- Player.count <$> mkPlayers plan
let pMultiple = product [1 .. pCount]
if 0 == (buildTreasures `mod` pMultiple)
then Right ()
else Left [InvalidBuildTreasures pMultiple]
validateTreasurePlayerRatio :: Validate f => BuildPlan -> Int -> f [BuildError] ()
validateTreasurePlayerRatio plan buildTreasures = either (_Failure #) (_Success #) $ do
pCount <- Player.count <$> mkPlayers plan
let pMultiple = product [1 .. pCount]
if 0 == (buildTreasures `mod` pMultiple) then Right () else Left [InvalidBuildTreasures pMultiple]

validateTilePosition
:: (Validate f, Applicative (f [BuildError]))
Expand All @@ -242,10 +169,7 @@ validateTilePosition ps t = case t of
_ -> _Success # t

validatePos
:: (Validate f, Applicative (f [BuildError]))
=> BuildPositions
-> Position
-> f [BuildError] ()
:: (Validate f, Applicative (f [BuildError])) => BuildPositions -> Position -> f [BuildError] ()
validatePos ps p = () <$ validate [UnknownTilePosition p] (`elem` ps) p

hasUniqueElements :: (Ord a) => NonEmpty a -> Bool
Expand All @@ -259,9 +183,10 @@ validateSameLength
-> t b
-> f [BuildError] ()
validateSameLength errTooFew errTooMany expected actual =
()
<$ validate [errTooFew] (uncurry (<=)) (lengths expected actual)
<* validate [errTooMany] (uncurry (>=)) (lengths expected actual)
() <$ validate [errTooFew] (uncurry (<=)) (lengths expected actual) <* validate
[errTooMany]
(uncurry (>=))
(lengths expected actual)
where lengths l r = bimap length length (l, r)

hasTreasure :: BuildTile -> Bool
Expand Down Expand Up @@ -321,10 +246,7 @@ board =
<> replicate 12 BuildPath

positions :: NonEmpty Position
positions =
NonEmpty.fromList
$ [ V2 row col | row <- [1 .. 7], col <- [1 .. 7] ]
<> [V2 0 2]
positions = NonEmpty.fromList $ [ V2 row col | row <- [1 .. 7], col <- [1 .. 7] ] <> [V2 0 2]

-- isFixed :: BuildTile -> Bool
-- isFixed (BuildGate _ _ ) = True
Expand Down
12 changes: 5 additions & 7 deletions lib/Labyrinth/Store.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,17 +12,15 @@ module Labyrinth.Store
where

import Brick
import Control.Lens ( (^.) )
import Control.Lens ( (^.) )
import Labyrinth.Store.Internal
import qualified Labyrinth.Store.Event.Modal as Modal
import Labyrinth.UI ( Name )
import qualified Labyrinth.UI.Screen.Splash as Splash
import Labyrinth.UI ( Name )

initial :: Store e
initial = Store { _state = Splash Splash.initial, _modals = [] }
initial = Store { _state = Splash, _modals = [] }

isModalEvent :: Ord e => Store e -> BrickEvent Name e -> Bool
isModalEvent store ev = isShowingModal store || Modal.isModalEvent ev
isModalEvent :: Store e -> BrickEvent Name e -> Bool
isModalEvent store _ = isShowingModal store

isShowingModal :: Store e -> Bool
isShowingModal = not . null . (^. modals)
Loading

0 comments on commit a2d1964

Please sign in to comment.