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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Lenses
( positionedCharacter
, character
, characterPosition
, updateCharacterVision
, getInitialState
, initialStateFromSeed
-- * Collisions
, Collision(..)
, entityCollision
, collisionAt
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import System.Random
import Control.Monad.State
import Control.Monad.Random (getRandom)
--------------------------------------------------------------------------------
import Xanthous.Game.State
import Xanthous.Data
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.EntityMap.Graphics (visiblePositions)
import Xanthous.Entities.Character (Character, mkCharacter)
import Xanthous.Entities.Environment (Door, open, GroundMessage)
import Xanthous.Entities.Item (Item)
import Xanthous.Entities.Creature (Creature)
import Xanthous.Entities.Entities ()
--------------------------------------------------------------------------------
getInitialState :: IO GameState
getInitialState = initialStateFromSeed <$> getRandom
initialStateFromSeed :: Int -> GameState
initialStateFromSeed seed =
let _randomGen = mkStdGen seed
chr = mkCharacter
(_characterEntityID, _entities)
= EntityMap.insertAtReturningID
(Position 0 0)
(SomeEntity chr)
mempty
_messageHistory = mempty
_revealedPositions = mempty
_promptState = NoPrompt
_debugState = DebugState
{ _allRevealed = False
}
in GameState {..}
positionedCharacter :: Lens' GameState (Positioned Character)
positionedCharacter = lens getPositionedCharacter setPositionedCharacter
where
setPositionedCharacter :: GameState -> Positioned Character -> GameState
setPositionedCharacter game chr
= game
& entities . at (game ^. characterEntityID)
?~ fmap SomeEntity chr
getPositionedCharacter :: GameState -> Positioned Character
getPositionedCharacter game
= over positioned
( fromMaybe (error "Invariant error: Character was not a character!")
. downcastEntity
)
. fromMaybe (error "Invariant error: Character not found!")
$ EntityMap.lookupWithPosition
(game ^. characterEntityID)
(game ^. entities)
character :: Lens' GameState Character
character = positionedCharacter . positioned
characterPosition :: Lens' GameState Position
characterPosition = positionedCharacter . position
visionRadius :: Word
visionRadius = 12 -- TODO make this dynamic
-- | Update the revealed entities at the character's position based on their vision
updateCharacterVision :: GameState -> GameState
updateCharacterVision game =
let charPos = game ^. characterPosition
visible = visiblePositions charPos visionRadius $ game ^. entities
in game & revealedPositions <>~ visible
data Collision
= Stop
| Combat
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData)
entityCollision
:: ( MonoFoldable (f SomeEntity)
, Foldable f
, Element (f SomeEntity) ~ SomeEntity
, AsEmpty (f SomeEntity)
)
=> f SomeEntity
-> Maybe Collision
entityCollision Empty = Nothing
entityCollision ents
-- TODO track entity collision in the Entity class
| any (entityIs @Creature) ents = pure Combat
| all (\e ->
entityIs @Item e
|| entityIs @GroundMessage e
) ents = Nothing
| doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
, all (view open) doors = Nothing
| otherwise = pure Stop
collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
collisionAt pos = uses (entities . EntityMap.atPosition pos) entityCollision
|
