src/Xanthous/Game.hs


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

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
module Xanthous.Game
  ( GameState(..)
  , entities
  , getInitialState

  , positionedCharacter
  , character
  , characterPosition
  ) where

import Xanthous.Prelude
import Test.QuickCheck.Arbitrary

import Xanthous.Data.EntityMap (EntityMap, EntityID)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data (Positioned, Position(..), positioned, position)
import Xanthous.Entities
import Xanthous.Entities.SomeEntity
import Xanthous.Entities.Character

data GameState = GameState
  { _entities          :: EntityMap SomeEntity
  , _characterEntityID :: EntityID
  }
  deriving stock (Show, Eq)
makeLenses ''GameState

instance Arbitrary GameState where
  arbitrary = do
    ents <- arbitrary
    char <- arbitrary
    pure $ getInitialState
      & entities .~ ents
      & positionedCharacter .~ char

getInitialState :: GameState
getInitialState =
  let char = mkCharacter
      (_characterEntityID, _entities)
        = EntityMap.insertAtReturningID
          (Position 0 0)
          (SomeEntity char)
          mempty
  in GameState {..}

positionedCharacter :: Lens' GameState (Positioned Character)
positionedCharacter = lens getPositionedCharacter setPositionedCharacter
  where
    setPositionedCharacter :: GameState -> Positioned Character -> GameState
    setPositionedCharacter game char
      = game
      &  entities . at (game ^. characterEntityID)
      ?~ fmap SomeEntity char

    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