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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
|
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Game.State
( GameState(..)
, entities
, levels
, revealedPositions
, messageHistory
, randomGen
, activePanel
, promptState
, characterEntityID
, autocommand
, memo
, GamePromptState(..)
-- * Game Level
, GameLevel(..)
, levelEntities
, upStaircasePosition
, levelRevealedPositions
-- * Messages
, MessageHistory(..)
, HasMessages(..)
, HasTurn(..)
, HasDisplayedTurn(..)
, pushMessage
, previousMessage
, nextTurn
-- * Autocommands
, Autocommand(..)
, AutocommandState(..)
, _NoAutocommand
, _ActiveAutocommand
-- * App monad
, AppT(..)
, AppM
, runAppT
-- * Entities
, Draw(..)
, Brain(..)
, Brainless(..)
, brainVia
, Collision(..)
, Entity(..)
, SomeEntity(..)
, downcastEntity
, _SomeEntity
, entityIs
, entityTypeName
-- ** Vias
, Color(..)
, DrawNothing(..)
, DrawRawChar(..)
, DrawRawCharPriority(..)
, DrawCharacter(..)
, DrawStyledCharacter(..)
, DeriveEntity(..)
-- ** Field classes
, HasChar(..)
, HasStyle(..)
-- * Debug State
, DebugState(..)
, debugState
, allRevealed
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.List.NonEmpty ( NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Typeable
import Data.Coerce
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Control.Monad.Random.Class
import Control.Monad.State
import Control.Monad.Trans.Control (MonadTransControl(..))
import Control.Monad.Trans.Compose
import Control.Monad.Morph (MFunctor(..))
import Brick (EventM, Widget, raw, str, emptyWidget)
import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
import qualified Data.Aeson as JSON
import Data.Aeson.Generic.DerivingVia
import Data.Generics.Product.Fields
import qualified Graphics.Vty.Attributes as Vty
import qualified Graphics.Vty.Image as Vty
--------------------------------------------------------------------------------
import Xanthous.Util (KnownBool(..))
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
import Xanthous.Data
import Xanthous.Data.App
import Xanthous.Data.Levels
import Xanthous.Data.EntityMap (EntityMap, EntityID)
import Xanthous.Data.EntityChar
import Xanthous.Data.VectorBag
import Xanthous.Data.Entities
import Xanthous.Orphans ()
import Xanthous.Game.Prompt
import Xanthous.Game.Env
import Xanthous.Game.Memo (MemoState)
--------------------------------------------------------------------------------
data MessageHistory
= MessageHistory
{ _messages :: Map Word (NonEmpty Text)
, _turn :: Word
, _displayedTurn :: Maybe Word
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary MessageHistory
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
MessageHistory
makeFieldsNoPrefix ''MessageHistory
instance Semigroup MessageHistory where
(MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) =
MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of
(_, Nothing) -> Nothing
(Just t, _) -> Just t
(Nothing, Just t) -> Just t
instance Monoid MessageHistory where
mempty = MessageHistory mempty 0 Nothing
type instance Element MessageHistory = [Text]
instance MonoFunctor MessageHistory where
omap f mh@(MessageHistory _ t _) =
mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<)
instance MonoComonad MessageHistory where
oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt)
oextend cok mh@(MessageHistory _ t dt) =
mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh)
pushMessage :: Text -> MessageHistory -> MessageHistory
pushMessage msg mh@(MessageHistory _ turn' _) =
mh
& messages . at turn' %~ \case
Nothing -> Just $ msg :| mempty
Just msgs -> Just $ msg <| msgs
& displayedTurn .~ Nothing
nextTurn :: MessageHistory -> MessageHistory
nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
previousMessage :: MessageHistory -> MessageHistory
previousMessage mh = mh & displayedTurn .~ maximumOf
(messages . ifolded . asIndex . filtered (< mh ^. turn))
mh
--------------------------------------------------------------------------------
data GamePromptState m where
NoPrompt :: GamePromptState m
WaitingPrompt :: Text -> Prompt m -> GamePromptState m
deriving stock (Show, Generic)
deriving anyclass (NFData)
-- | Non-injective! We never try to serialize waiting prompts, since:
--
-- * they contain callback functions
-- * we can't save the game when in a prompt anyway
instance ToJSON (GamePromptState m) where
toJSON _ = Null
-- | Always expects Null
instance FromJSON (GamePromptState m) where
parseJSON Null = pure NoPrompt
parseJSON _ = fail "Invalid GamePromptState; expected null"
instance CoArbitrary (GamePromptState m) where
coarbitrary NoPrompt = variant @Int 1
coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt
instance Function (GamePromptState m) where
function = functionMap onlyNoPrompt (const NoPrompt)
where
onlyNoPrompt NoPrompt = ()
onlyNoPrompt (WaitingPrompt _ _) =
error "Can't handle prompts in Function!"
--------------------------------------------------------------------------------
newtype AppT m a
= AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a }
deriving ( Functor
, Applicative
, Monad
, MonadState GameState
, MonadReader GameEnv
, MonadIO
)
via (ReaderT GameEnv (StateT GameState m))
deriving ( MonadTrans
, MFunctor
)
via (ReaderT GameEnv `ComposeT` StateT GameState)
type AppM = AppT (EventM ResourceName)
--------------------------------------------------------------------------------
class Draw a where
drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n
drawWithNeighbors = const draw
draw :: a -> Widget n
draw = drawWithNeighbors $ pure mempty
-- | higher priority gets drawn on top
drawPriority :: a -> Word
drawPriority = const minBound
instance Draw a => Draw (Positioned a) where
drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
draw (Positioned _ a) = draw a
newtype DrawCharacter (char :: Symbol) (a :: Type) where
DrawCharacter :: a -> DrawCharacter char a
instance KnownSymbol char => Draw (DrawCharacter char a) where
draw _ = str $ symbolVal @char Proxy
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
class KnownColor (color :: Color) where
colorVal :: forall proxy. proxy color -> Vty.Color
instance KnownColor 'Black where colorVal _ = Vty.black
instance KnownColor 'Red where colorVal _ = Vty.red
instance KnownColor 'Green where colorVal _ = Vty.green
instance KnownColor 'Yellow where colorVal _ = Vty.yellow
instance KnownColor 'Blue where colorVal _ = Vty.blue
instance KnownColor 'Magenta where colorVal _ = Vty.magenta
instance KnownColor 'Cyan where colorVal _ = Vty.cyan
instance KnownColor 'White where colorVal _ = Vty.white
class KnownMaybeColor (maybeColor :: Maybe Color) where
maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color
instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing
instance KnownColor color => KnownMaybeColor ('Just color) where
maybeColorVal _ = Just $ colorVal @color Proxy
newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where
DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
instance
( KnownMaybeColor fg
, KnownMaybeColor bg
, KnownSymbol char
)
=> Draw (DrawStyledCharacter fg bg char a) where
draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
where attr = Vty.Attr
{ Vty.attrStyle = Vty.Default
, Vty.attrForeColor = maybe Vty.Default Vty.SetTo
$ maybeColorVal @fg Proxy
, Vty.attrBackColor = maybe Vty.Default Vty.SetTo
$ maybeColorVal @bg Proxy
, Vty.attrURL = Vty.Default
}
instance Draw EntityChar where
draw EntityChar{..} = raw $ Vty.string _style [_char]
--------------------------------------------------------------------------------
newtype DrawNothing (a :: Type) = DrawNothing a
instance Draw (DrawNothing a) where
draw = const emptyWidget
drawPriority = const 0
newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
instance
forall rawField a raw.
( HasField rawField a a raw raw
, HasChar raw EntityChar
) => Draw (DrawRawChar rawField a) where
draw (DrawRawChar e) = draw $ e ^. field @rawField . char
newtype DrawRawCharPriority
(rawField :: Symbol)
(priority :: Nat)
(a :: Type)
= DrawRawCharPriority a
instance
forall rawField priority a raw.
( HasField rawField a a raw raw
, KnownNat priority
, HasChar raw EntityChar
) => Draw (DrawRawCharPriority rawField priority a) where
draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
drawPriority = const . fromIntegral $ natVal @priority Proxy
--------------------------------------------------------------------------------
class Brain a where
step :: Ticks -> Positioned a -> AppM (Positioned a)
-- | Does this entity ever move on its own?
entityCanMove :: a -> Bool
entityCanMove = const False
newtype Brainless a = Brainless a
instance Brain (Brainless a) where
step = const pure
-- | Workaround for the inability to use DerivingVia on Brain due to the lack of
-- higher-order roles (specifically AppT not having its last type argument have
-- role representational bc of StateT)
brainVia
:: forall brain entity. (Coercible entity brain, Brain brain)
=> (entity -> brain) -- ^ constructor, ignored
-> (Ticks -> Positioned entity -> AppM (Positioned entity))
brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
--------------------------------------------------------------------------------
class ( Show a, Eq a, Ord a, NFData a
, ToJSON a, FromJSON a
, Draw a, Brain a
) => Entity a where
entityAttributes :: a -> EntityAttributes
entityAttributes = const defaultEntityAttributes
description :: a -> Text
entityChar :: a -> EntityChar
entityCollision :: a -> Maybe Collision
entityCollision = const $ Just Stop
data SomeEntity where
SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
instance Show SomeEntity where
show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
instance Eq SomeEntity where
(SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
Just Refl -> a == b
_ -> False
instance Ord SomeEntity where
compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of
Just Refl -> compare a b
_ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb)
instance NFData SomeEntity where
rnf (SomeEntity ent) = ent `deepseq` ()
instance ToJSON SomeEntity where
toJSON (SomeEntity ent) = entityToJSON ent
where
entityToJSON :: forall entity. (Entity entity, Typeable entity)
=> entity -> JSON.Value
entityToJSON entity = JSON.object
[ "type" JSON..= tshow (typeRep @_ @entity Proxy)
, "data" JSON..= toJSON entity
]
instance Draw SomeEntity where
drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
drawPriority (SomeEntity ent) = drawPriority ent
instance Brain SomeEntity where
step ticks (Positioned p (SomeEntity ent)) =
fmap SomeEntity <$> step ticks (Positioned p ent)
entityCanMove (SomeEntity ent) = entityCanMove ent
downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
downcastEntity (SomeEntity e) = cast e
entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool
entityIs = isJust . downcastEntity @a
_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
_SomeEntity = prism' SomeEntity downcastEntity
-- | Get the name of the type of 'SomeEntity' as a string
entityTypeName :: SomeEntity -> Text
entityTypeName (SomeEntity e) = pack . tyConName . typeRepTyCon $ typeOf e
newtype DeriveEntity
(blocksVision :: Bool)
(description :: Symbol)
(entityChar :: Symbol)
(entity :: Type)
= DeriveEntity entity
deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw)
instance Brain entity => Brain (DeriveEntity b d c entity) where
step = brainVia $ \(DeriveEntity e) -> e
instance
( KnownBool blocksVision
, KnownSymbol description
, KnownSymbol entityChar
, Show entity, Eq entity, Ord entity, NFData entity
, ToJSON entity, FromJSON entity
, Draw entity, Brain entity
)
=> Entity (DeriveEntity blocksVision description entityChar entity) where
entityAttributes _ = defaultEntityAttributes
& blocksVision .~ boolVal @blocksVision
description _ = pack . symbolVal $ Proxy @description
entityChar _ = fromString . symbolVal $ Proxy @entityChar
--------------------------------------------------------------------------------
data GameLevel = GameLevel
{ _levelEntities :: !(EntityMap SomeEntity)
, _upStaircasePosition :: !Position
, _levelRevealedPositions :: !(Set Position)
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
deriving (ToJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
GameLevel
--------------------------------------------------------------------------------
data Autocommand
= AutoMove Direction
| AutoRest
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary Autocommand
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
data AutocommandState
= NoAutocommand
| ActiveAutocommand Autocommand (Async ())
deriving stock (Eq, Ord, Generic)
deriving anyclass (Hashable)
instance Show AutocommandState where
show NoAutocommand = "NoAutocommand"
show (ActiveAutocommand ac _) =
"(ActiveAutocommand " <> show ac <> " <Async>)"
instance ToJSON AutocommandState where
toJSON = const Null
instance FromJSON AutocommandState where
parseJSON Null = pure NoAutocommand
parseJSON _ = fail "Invalid AutocommandState; expected null"
instance NFData AutocommandState where
rnf NoAutocommand = ()
rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` ()
instance CoArbitrary AutocommandState where
coarbitrary NoAutocommand = variant @Int 1
coarbitrary (ActiveAutocommand ac t)
= variant @Int 2
. coarbitrary ac
. coarbitrary (hash t)
instance Function AutocommandState where
function = functionMap onlyNoAC (const NoAutocommand)
where
onlyNoAC NoAutocommand = ()
onlyNoAC _ = error "Can't handle autocommands in Function"
--------------------------------------------------------------------------------
data DebugState = DebugState
{ _allRevealed :: !Bool
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
DebugState
{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-}
instance Arbitrary DebugState where
arbitrary = genericArbitrary
data GameState = GameState
{ _levels :: !(Levels GameLevel)
, _characterEntityID :: !EntityID
, _messageHistory :: !MessageHistory
, _randomGen :: !StdGen
-- | The active panel displayed in the UI, if any
, _activePanel :: !(Maybe Panel)
, _promptState :: !(GamePromptState AppM)
, _debugState :: !DebugState
, _autocommand :: !AutocommandState
, _memo :: MemoState
}
deriving stock (Show, Generic)
deriving anyclass (NFData)
deriving (ToJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
GameState
makeLenses ''GameLevel
makeLenses ''GameState
entities :: Lens' GameState (EntityMap SomeEntity)
entities = levels . current . levelEntities
revealedPositions :: Lens' GameState (Set Position)
revealedPositions = levels . current . levelRevealedPositions
instance Eq GameState where
(==) = (==) `on` \gs ->
( gs ^. entities
, gs ^. revealedPositions
, gs ^. characterEntityID
, gs ^. messageHistory
, gs ^. activePanel
, gs ^. debugState
)
--------------------------------------------------------------------------------
runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState)
runAppT appt env initialState
= flip runStateT initialState
. flip runReaderT env
. unAppT
$ appt
instance (Monad m) => MonadRandom (AppT m) where
getRandomR rng = randomGen %%= randomR rng
getRandom = randomGen %%= random
getRandomRs rng = uses randomGen $ randomRs rng
getRandoms = uses randomGen randoms
instance MonadTransControl AppT where
type StT AppT a = (a, GameState)
liftWith f
= AppT
. ReaderT $ \e
-> StateT $ \s
-> (,s) <$> f (\action -> runAppT action e s)
restoreT = AppT . ReaderT . const . StateT . const
--------------------------------------------------------------------------------
makeLenses ''DebugState
makePrisms ''AutocommandState
|