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
|
module Xanthous.App (makeApp) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Brick hiding (App, halt, continue, raw)
import qualified Brick
import Graphics.Vty.Attributes (defAttr)
import Graphics.Vty.Input.Events (Event(EvKey))
import Control.Monad.State (get)
import Control.Monad.Random (getRandom)
--------------------------------------------------------------------------------
import Xanthous.Command
import Xanthous.Data
( move
, Position(..)
, Dimensions'(Dimensions)
, Dimensions
, positionFromPair
)
import Xanthous.Data.EntityMap (EntityMap)
import Xanthous.Game
import Xanthous.Game.Draw (drawGame)
import Xanthous.Monad
import Xanthous.Resource (Name)
--------------------------------------------------------------------------------
import Xanthous.Entities.Creature (Creature)
import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.RawTypes (EntityRaw(..))
import Xanthous.Entities.Raws (raw)
import Xanthous.Entities
import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import Xanthous.Generators.LevelContents
--------------------------------------------------------------------------------
type App = Brick.App GameState () Name
type AppM a = AppT (EventM Name) a
makeApp :: IO App
makeApp = pure $ Brick.App
{ appDraw = drawGame
, appChooseCursor = const headMay
, appHandleEvent = \state event -> runAppM (handleEvent event) state
, appStartEvent = runAppM $ startEvent >> get
, appAttrMap = const $ attrMap defAttr []
}
runAppM :: AppM a -> GameState -> EventM Name a
runAppM appm = fmap fst . runAppT appm
testGormlak :: Creature
testGormlak =
let Just (Creature gormlak) = raw "gormlak"
in Creature.newWithType gormlak
startEvent :: AppM ()
startEvent = do
say_ ["welcome"]
(level, charPos) <-
generateLevel SCaveAutomata CaveAutomata.defaultParams
$ Dimensions 80 80
entities <>= level
characterPosition .= charPos
-- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
handleEvent :: BrickEvent Name () -> AppM (Next GameState)
handleEvent (VtyEvent (EvKey k mods))
| Just command <- commandFromKey k mods
= do messageHistory %= hideMessage
handleCommand command
handleEvent _ = continue
handleCommand :: Command -> AppM (Next GameState)
handleCommand Quit = halt
handleCommand (Move dir) = do
newPos <- uses characterPosition $ move dir
collisionAt newPos >>= \case
Nothing -> characterPosition .= newPos
Just Combat -> undefined
Just Stop -> pure ()
continue
handleCommand PreviousMessage = do
messageHistory %= popMessage
continue
--------------------------------------------------------------------------------
generateLevel
:: SGenerator gen
-> Params gen
-> Dimensions
-> AppM (EntityMap SomeEntity, Position)
generateLevel g ps dims = do
gen <- use randomGen
let cells = generate g ps dims gen
_ <- getRandom @_ @Int -- perturb the generator, so we don't get the same level twice
charPos <- positionFromPair <$> chooseCharacterPosition cells
let level = SomeEntity <$> cellsToWalls cells
pure (level, charPos)
|
