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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Lenses
( clearMemo
, positionedCharacter
, character
, characterPosition
, updateCharacterVision
, characterVisiblePositions
, characterVisibleEntities
, positionIsCharacterVisible
, getInitialState
, initialStateFromSeed
, entitiesAtCharacter
, revealedEntitiesAtPosition
, hearingRadius
-- * Collisions
, Collision(..)
, entitiesCollision
, collisionAt
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import System.Random
import Control.Monad.State
import Control.Monad.Random (getRandom)
--------------------------------------------------------------------------------
import Xanthous.Game.State
import qualified Xanthous.Game.Memo as Memo
import Xanthous.Data
import Xanthous.Data.Levels
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.EntityMap.Graphics
(visiblePositions, visibleEntities)
import Xanthous.Data.VectorBag
import Xanthous.Entities.Character (Character, mkCharacter)
import {-# SOURCE #-} Xanthous.Entities.Entities ()
import Xanthous.Game.Memo (emptyMemoState, MemoState)
import Xanthous.Data.Memo (fillWithM, Memoized)
--------------------------------------------------------------------------------
getInitialState :: IO GameState
getInitialState = initialStateFromSeed <$> getRandom
initialStateFromSeed :: Int -> GameState
initialStateFromSeed seed =
let _randomGen = mkStdGen seed
chr = mkCharacter
_upStaircasePosition = Position 0 0
(_characterEntityID, _levelEntities)
= EntityMap.insertAtReturningID
_upStaircasePosition
(SomeEntity chr)
mempty
_levelRevealedPositions = mempty
level = GameLevel {..}
_levels = oneLevel level
_messageHistory = mempty
_promptState = NoPrompt
_activePanel = Nothing
_debugState = DebugState
{ _allRevealed = False
}
_autocommand = NoAutocommand
_memo = emptyMemoState
in GameState {..}
clearMemo :: MonadState GameState m => Lens' MemoState (Memoized k v) -> m ()
clearMemo l = memo %= Memo.clear l
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
-- TODO make this dynamic
visionRadius :: Word
visionRadius = 12
-- TODO make this dynamic
hearingRadius :: Word
hearingRadius = 12
-- | Update the revealed entities at the character's position based on their
-- vision
updateCharacterVision :: GameState -> GameState
updateCharacterVision = execState $ do
positions <- characterVisiblePositions
revealedPositions <>= positions
characterVisiblePositions :: MonadState GameState m => m (Set Position)
characterVisiblePositions = do
charPos <- use characterPosition
fillWithM
(memo . Memo.characterVisiblePositions)
charPos
(uses entities $ visiblePositions charPos visionRadius)
characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
characterVisibleEntities game =
let charPos = game ^. characterPosition
in visibleEntities charPos visionRadius $ game ^. entities
positionIsCharacterVisible :: MonadState GameState m => Position -> m Bool
positionIsCharacterVisible p = (p `elem`) <$> characterVisiblePositions
-- ^ TODO optimize
entitiesCollision
:: ( Functor f
, forall xx. MonoFoldable (f xx)
, Element (f SomeEntity) ~ SomeEntity
, Element (f (Maybe Collision)) ~ Maybe Collision
, Show (f (Maybe Collision))
, Show (f SomeEntity)
)
=> f SomeEntity
-> Maybe Collision
entitiesCollision = join . maximumMay . fmap entityCollision
collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision
entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity)
entitiesAtCharacter = lens getter setter
where
getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition)
setter gs ents = gs
& entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents
-- | Returns all entities at the given position that are revealed to the
-- character.
--
-- Concretely, this is either entities that are *currently* visible to the
-- character, or entities, that are immobile and that the character has seen
-- before
revealedEntitiesAtPosition
:: MonadState GameState m
=> Position
-> m (VectorBag SomeEntity)
revealedEntitiesAtPosition p = do
allRev <- use $ debugState . allRevealed
cvps <- characterVisiblePositions
entitiesAtPosition <- use $ entities . EntityMap.atPosition p
revealed <- use revealedPositions
let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition
pure $ if | allRev || p `member` cvps
-> entitiesAtPosition
| p `member` revealed
-> immobileEntitiesAtPosition
| otherwise
-> mempty
|
