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
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Level
( generate
, Generator(..)
, SGenerator(..)
, GeneratorInput(..)
, generateFromInput
, parseGeneratorInput
, showCells
, Level(..)
, levelWalls
, levelItems
, levelCreatures
, levelDoors
, levelCharacterPosition
, levelTutorialMessage
, levelExtra
, generateLevel
, levelToEntityMap
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Data.Array.Unboxed
import qualified Options.Applicative as Opt
import Control.Monad.Random
--------------------------------------------------------------------------------
import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata
import qualified Xanthous.Generators.Level.Dungeon as Dungeon
import Xanthous.Generators.Level.Util
import Xanthous.Generators.Level.LevelContents
import Xanthous.Generators.Level.Village as Village
import Xanthous.Data (Dimensions, Position'(Position), Position)
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment
import Xanthous.Entities.Item (Item)
import Xanthous.Entities.Creature (Creature)
import Xanthous.Game.State (SomeEntity(..))
import Linear.V2
--------------------------------------------------------------------------------
data Generator
= CaveAutomata
| Dungeon
deriving stock (Show, Eq)
data SGenerator (gen :: Generator) where
SCaveAutomata :: SGenerator 'CaveAutomata
SDungeon :: SGenerator 'Dungeon
type family Params (gen :: Generator) :: Type where
Params 'CaveAutomata = CaveAutomata.Params
Params 'Dungeon = Dungeon.Params
generate
:: RandomGen g
=> SGenerator gen
-> Params gen
-> Dimensions
-> g
-> Cells
generate SCaveAutomata = CaveAutomata.generate
generate SDungeon = Dungeon.generate
data GeneratorInput where
GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput
generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells
generateFromInput (GeneratorInput sg ps) = generate sg ps
parseGeneratorInput :: Opt.Parser GeneratorInput
parseGeneratorInput = Opt.subparser
$ generatorCommand SCaveAutomata
"cave"
"Cellular-automata based cave generator"
CaveAutomata.parseParams
<> generatorCommand SDungeon
"dungeon"
"Classic dungeon map generator"
Dungeon.parseParams
where
generatorCommand sgen name desc parseParams =
Opt.command name
(Opt.info
(GeneratorInput sgen <$> parseParams)
(Opt.progDesc desc)
)
showCells :: Cells -> Text
showCells arr =
let (V2 minX minY, V2 maxX maxY) = bounds arr
showCellVal True = "x"
showCellVal False = " "
showCell = showCellVal . (arr !)
row r = foldMap (showCell . (`V2` r)) [minX..maxX]
rows = row <$> [minY..maxY]
in intercalate "\n" rows
cellsToWalls :: Cells -> EntityMap Wall
cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
where
maybeInsertWall em (pos@(V2 x y), True)
| not (surroundedOnAllSides pos) =
let x' = fromIntegral x
y' = fromIntegral y
in EntityMap.insertAt (Position x' y') Wall em
maybeInsertWall em _ = em
surroundedOnAllSides pos = numAliveNeighbors cells pos == 8
--------------------------------------------------------------------------------
data Level = Level
{ _levelWalls :: !(EntityMap Wall)
, _levelDoors :: !(EntityMap Door)
, _levelItems :: !(EntityMap Item)
, _levelCreatures :: !(EntityMap Creature)
, _levelTutorialMessage :: !(EntityMap GroundMessage)
, _levelStaircases :: !(EntityMap Staircase)
, _levelExtra :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack...
, _levelCharacterPosition :: !Position
}
deriving stock (Generic)
deriving anyclass (NFData)
makeLenses ''Level
generateLevel
:: MonadRandom m
=> SGenerator gen
-> Params gen
-> Dimensions
-> Word -- ^ Level number, starting at 0
-> m Level
generateLevel gen ps dims num = do
rand <- mkStdGen <$> getRandom
let cells = generate gen ps dims rand
_levelWalls = cellsToWalls cells
village <- generateVillage cells gen
let _levelExtra = village
_levelItems <- randomItems cells
_levelCreatures <- randomCreatures num cells
_levelDoors <- randomDoors cells
_levelCharacterPosition <- chooseCharacterPosition cells
let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
downStaircase <- placeDownStaircase cells
let _levelStaircases = upStaircase <> downStaircase
_levelTutorialMessage <-
if num == 0
then tutorialMessage cells _levelCharacterPosition
else pure mempty
pure Level {..}
levelToEntityMap :: Level -> EntityMap SomeEntity
levelToEntityMap level
= (SomeEntity <$> level ^. levelWalls)
<> (SomeEntity <$> level ^. levelDoors)
<> (SomeEntity <$> level ^. levelItems)
<> (SomeEntity <$> level ^. levelCreatures)
<> (SomeEntity <$> level ^. levelTutorialMessage)
<> (SomeEntity <$> level ^. levelStaircases)
<> (level ^. levelExtra)
generateVillage
:: MonadRandom m
=> Cells -- ^ Wall positions
-> SGenerator gen
-> m (EntityMap SomeEntity)
generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions
generateVillage _ _ = pure mempty
|
