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
|
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Xanthous.Game
( GameState(..)
, entities
, messageHistory
, randomGen
, getInitialState
, positionedCharacter
, character
, characterPosition
, MessageHistory(..)
, pushMessage
, popMessage
, hideMessage
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.List.NonEmpty ( NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
import Xanthous.Data.EntityMap (EntityMap, EntityID)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data (Positioned, Position(..), positioned, position)
import Xanthous.Entities (SomeEntity(..), downcastEntity)
import Xanthous.Entities.Character
import Xanthous.Entities.Arbitrary ()
import Xanthous.Orphans ()
--------------------------------------------------------------------------------
data MessageHistory
= NoMessageHistory
| MessageHistory (NonEmpty Text) Bool
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
instance Arbitrary MessageHistory where
arbitrary = genericArbitrary
pushMessage :: Text -> MessageHistory -> MessageHistory
pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
popMessage :: MessageHistory -> MessageHistory
popMessage NoMessageHistory = NoMessageHistory
popMessage (MessageHistory msgs False) = MessageHistory msgs True
popMessage (MessageHistory msgs@(_ :| []) _) = MessageHistory msgs True
popMessage (MessageHistory (_ :| (msg : msgs)) True) = MessageHistory (msg :| msgs) True
hideMessage :: MessageHistory -> MessageHistory
hideMessage NoMessageHistory = NoMessageHistory
hideMessage (MessageHistory msgs _) = MessageHistory msgs False
data GameState = GameState
{ _entities :: EntityMap SomeEntity
, _characterEntityID :: EntityID
, _messageHistory :: MessageHistory
, _randomGen :: StdGen
}
deriving stock (Show)
makeLenses ''GameState
instance Eq GameState where
(GameState es₁ ceid₁ mh₁ _) == (GameState es₂ ceid₂ mh₂ _)
= es₁ == es₂
&& ceid₁ == ceid₂
&& mh₁ == mh₂
instance Arbitrary GameState where
arbitrary = do
char <- arbitrary @Character
charPos <- arbitrary
_messageHistory <- arbitrary
(_characterEntityID, _entities) <- arbitrary <&>
EntityMap.insertAtReturningID charPos (SomeEntity char)
_randomGen <- mkStdGen <$> arbitrary
pure $ GameState {..}
getInitialState :: IO GameState
getInitialState = do
_randomGen <- getStdGen
let char = mkCharacter
(_characterEntityID, _entities)
= EntityMap.insertAtReturningID
(Position 0 0)
(SomeEntity char)
mempty
_messageHistory = NoMessageHistory
pure 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
|
