blob: bb6508acdff74a6ddb970ebea11e70402b3e434a (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
{-# LANGUAGE ViewPatterns #-}
module Xanthous.Game.Draw
( drawGame
) where
import Xanthous.Prelude
import Brick hiding (loc)
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Data.List.NonEmpty(NonEmpty((:|)))
import Xanthous.Data (Position(Position), x, y, loc)
import Xanthous.Data.EntityMap (EntityMap, atPosition)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities
import Xanthous.Game
( GameState(..)
, entities
, revealedEntities
, characterPosition
, MessageHistory(..)
, messageHistory
)
import Xanthous.Resource (Name(..))
import Xanthous.Orphans ()
drawMessages :: MessageHistory -> Widget Name
drawMessages NoMessageHistory = emptyWidget
drawMessages (MessageHistory _ False) = emptyWidget
drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
-- an attempt to still take up a row even when no messages
-- drawMessages msgs = vLimit 1 . Widget Greedy Fixed . render $ case msgs of
-- NoMessageHistory -> padTop (Pad 2) $ str " "
-- (MessageHistory _ False) -> padTop (Pad 2) $ str " "
-- (MessageHistory (lastMessage :| _) True) -> txt lastMessage
drawEntities
:: EntityMap SomeEntity -- ^ visible entities
-> EntityMap SomeEntity -- ^ all entities
-> Widget Name
drawEntities em allEnts
= vBox rows
where
entityPositions = EntityMap.positions em
maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
rows = mkRow <$> [0..maxY]
mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
renderEntityAt pos =
let neighbors = EntityMap.neighbors pos allEnts
in maybe (str " ") (drawWithNeighbors neighbors)
$ em ^? atPosition pos . folded
drawMap :: GameState -> Widget Name
drawMap game
= viewport MapViewport Both
. showCursor Character (game ^. characterPosition . loc)
$ drawEntities
(game ^. revealedEntities)
(game ^. entities)
drawGame :: GameState -> [Widget Name]
drawGame game
= pure
. withBorderStyle unicode
$ drawMessages (game ^. messageHistory)
<=> border (drawMap game)
|
