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
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Lenses
( positionedCharacter
, character
, characterPosition
, updateCharacterVision
, characterVisiblePositions
, characterVisibleEntities
, getInitialState
, initialStateFromSeed
, entitiesAtCharacter
-- * 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 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 ()
--------------------------------------------------------------------------------
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
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
= game & revealedPositions <>~ characterVisiblePositions game
characterVisiblePositions :: GameState -> Set Position
characterVisiblePositions game =
let charPos = game ^. characterPosition
in visiblePositions charPos visionRadius $ game ^. entities
characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
characterVisibleEntities game =
let charPos = game ^. characterPosition
in visibleEntities charPos visionRadius $ game ^. entities
entitiesCollision
:: ( Functor f
, forall xx. MonoFoldable (f xx)
, forall xx. Element (f xx) ~ xx
, 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
|
