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
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Generators
( generate
, SGenerator(..)
, GeneratorInput
, generateFromInput
, parseGeneratorInput
, showCells
, Level(..)
, levelWalls
, levelItems
, levelCreatures
, levelCharacterPosition
, levelTutorialMessage
, generateLevel
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Level)
import Data.Array.Unboxed
import System.Random (RandomGen)
import qualified Options.Applicative as Opt
import Control.Monad.Random
--------------------------------------------------------------------------------
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import qualified Xanthous.Generators.Dungeon as Dungeon
import Xanthous.Generators.Util
import Xanthous.Generators.LevelContents
import Xanthous.Data (Dimensions, Position'(Position), Position)
import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment
import Xanthous.Entities.Item (Item)
import Xanthous.Entities.Creature (Creature)
--------------------------------------------------------------------------------
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 <$> pure sgen <*> parseParams)
(Opt.progDesc desc)
)
showCells :: Cells -> Text
showCells arr =
let ((minX, minY), (maxX, maxY)) = bounds arr
showCellVal True = "x"
showCellVal False = " "
showCell = showCellVal . (arr !)
row r = foldMap (showCell . (, 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@(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)
, _levelItems :: !(EntityMap Item)
, _levelCreatures :: !(EntityMap Creature)
, _levelTutorialMessage :: !(EntityMap GroundMessage)
, _levelCharacterPosition :: !Position
}
makeLenses ''Level
generateLevel :: MonadRandom m => SGenerator gen -> Params gen -> Dimensions -> m Level
generateLevel gen ps dims = do
rand <- mkStdGen <$> getRandom
let cells = generate gen ps dims rand
_levelWalls = cellsToWalls cells
_levelItems <- randomItems cells
_levelCreatures <- randomCreatures cells
_levelCharacterPosition <- chooseCharacterPosition cells
_levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
pure Level {..}
|
