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
|
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.LevelContents
( chooseCharacterPosition
, randomItems
, randomCreatures
, randomDoors
, placeDownStaircase
, tutorialMessage
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (any, toList)
--------------------------------------------------------------------------------
import Control.Monad.Random
import Data.Array.IArray (amap, bounds, rangeSize, (!))
import qualified Data.Array.IArray as Arr
import Data.Foldable (any, toList)
--------------------------------------------------------------------------------
import Xanthous.Generators.Util
import Xanthous.Random
import Xanthous.Data ( Position, _Position, positionFromPair
, rotations, arrayNeighbors, Neighbors(..)
, neighborPositions
)
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
import Xanthous.Entities.Raws (rawsWithType, RawType)
import qualified Xanthous.Entities.Item as Item
import Xanthous.Entities.Item (Item)
import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Creature (Creature)
import Xanthous.Entities.Environment
(GroundMessage(..), Door(..), unlockedDoor, Staircase(..))
import Xanthous.Messages (message_)
import Xanthous.Util.Graphics (circle)
--------------------------------------------------------------------------------
chooseCharacterPosition :: MonadRandom m => Cells -> m Position
chooseCharacterPosition = randomPosition
randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
randomItems = randomEntities Item.newWithType (0.0004, 0.001)
placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase)
placeDownStaircase cells = do
pos <- randomPosition cells
pure $ _EntityMap # [(pos, DownStaircase)]
randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
randomDoors cells = do
doorRatio <- getRandomR subsetRange
let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
doorPositions =
removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells
doors = zip doorPositions $ repeat unlockedDoor
pure $ _EntityMap # doors
where
removeAdjacent =
foldr (\pos acc ->
if pos `elem` (acc >>= toList . neighborPositions)
then acc
else pos : acc
) []
candidateCells = filter doorable $ Arr.indices cells
subsetRange = (0.8 :: Double, 1.0)
doorable pos =
not (fromMaybe True $ cells ^? ix pos)
&& any (teeish . fmap (fromMaybe True))
(rotations $ arrayNeighbors cells pos)
-- only generate doors at the *ends* of hallways, eg (where O is walkable,
-- X is a wall, and D is a door):
--
-- O O O
-- X D X
-- O
teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) =
and [tl, t, tr, b] && (and . fmap not) [l, r]
randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature)
randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)
tutorialMessage :: MonadRandom m
=> Cells
-> Position -- ^ CharacterPosition
-> m (EntityMap GroundMessage)
tutorialMessage cells characterPosition = do
let distance = 2
pos <- fmap (fromMaybe (error "No valid positions for tutorial message?"))
. choose . ChooseElement
$ accessiblePositionsWithin distance cells characterPosition
msg <- message_ ["tutorial", "message1"]
pure $ _EntityMap # [(pos, GroundMessage msg)]
where
accessiblePositionsWithin :: Int -> Cells -> Position -> [Position]
accessiblePositionsWithin dist valid pos =
review _Position
<$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py))
(circle (pos ^. _Position) dist)
randomEntities
:: forall entity raw m. (MonadRandom m, RawType raw)
=> (raw -> entity)
-> (Float, Float)
-> Cells
-> m (EntityMap entity)
randomEntities newWithType sizeRange cells =
case fromNullable $ rawsWithType @raw of
Nothing -> pure mempty
Just raws -> do
let len = rangeSize $ bounds cells
(numEntities :: Int) <-
floor . (* fromIntegral len) <$> getRandomR sizeRange
entities <- for [0..numEntities] $ const $ do
pos <- randomPosition cells
raw <- choose raws
let entity = newWithType raw
pure (pos, entity)
pure $ _EntityMap # entities
randomPosition :: MonadRandom m => Cells -> m Position
randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates
-- cellCandidates :: Cells -> Cells
cellCandidates :: Cells -> Set (Word, Word)
cellCandidates
-- find the largest contiguous region of cells in the cave.
= maximumBy (compare `on` length)
. fromMaybe (error "No regions generated! this should never happen.")
. fromNullable
. regions
-- cells ends up with true = wall, we want true = can put an item here
. amap not
|
