about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
blob: c692a3b47944793f52a8855c8b5f77e939b48b7d (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
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
178
{-# 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
        }
      _savefile = Nothing
      _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