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
|
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Level.LevelContents
( chooseCharacterPosition
, randomItems
, randomCreatures
, randomDoors
, placeDownStaircase
, tutorialMessage
, entityFromRaw
) 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 Linear.V2
--------------------------------------------------------------------------------
import Xanthous.Generators.Level.Util
import Xanthous.Random hiding (chance)
import qualified Xanthous.Random as Random
import Xanthous.Data
( positionFromV2, Position, _Position
, rotations, arrayNeighbors, Neighbors(..)
, neighborPositions
)
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
import Xanthous.Entities.Raws (rawsWithType, RawType, raw)
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)
import Xanthous.Entities.RawTypes
import Xanthous.Entities.Creature.Hippocampus (initialHippocampus)
import Xanthous.Entities.Common (inRightHand, asWieldedItem, wielded)
import Xanthous.Game.State (SomeEntity(SomeEntity))
--------------------------------------------------------------------------------
chooseCharacterPosition :: MonadRandom m => Cells -> m Position
chooseCharacterPosition = randomPosition
randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
randomItems = randomEntities (fmap Identity . 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 positionFromV2 . 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
=> Word -- ^ Level number, starting at 0
-> Cells
-> m (EntityMap Creature)
randomCreatures levelNumber
= randomEntities maybeNewCreature (0.0007, 0.002)
where
maybeNewCreature cType
| maybe True (canGenerate levelNumber) $ cType ^. generateParams
= Just <$> newCreatureWithType cType
| otherwise
= pure Nothing
newCreatureWithType :: MonadRandom m => CreatureType -> m Creature
newCreatureWithType _creatureType = do
let _hitpoints = _creatureType ^. maxHitpoints
_hippocampus = initialHippocampus
equipped <- fmap join
. traverse genEquipped
$ _creatureType
^.. generateParams . _Just . equippedItem . _Just
let _inventory = maybe id (\ei -> wielded .~ inRightHand ei) (headMay equipped) mempty
pure Creature.Creature {..}
where
genEquipped cei = do
doGen <- Random.chance $ cei ^. chance
let entName = cei ^. entityName
itemType =
fromMaybe (error $ "raw \"" <> unpack entName <> "\" not of type Item")
. preview _Item
. fromMaybe (error $ "Could not find raw: " <> unpack entName)
$ raw entName
item <- Item.newWithType itemType
if doGen
then pure [fromMaybe (error $ "raw \"" <> unpack entName <> "\" not wieldable")
$ preview asWieldedItem item]
else pure []
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
(\pt -> not $ valid ! (fromIntegral <$> pt))
(circle (pos ^. _Position) dist)
randomEntities
:: forall entity raw m t. (MonadRandom m, RawType raw, Functor t, Foldable t)
=> (raw -> m (t 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
r <- choose raws
entities <- newWithType r
pure $ (pos, ) <$> entities
pure $ _EntityMap # (entities >>= toList)
randomPosition :: MonadRandom m => Cells -> m Position
randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates
-- cellCandidates :: Cells -> Cells
cellCandidates :: Cells -> Set (V2 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
entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity
entityFromRaw (Creature ct) = SomeEntity <$> newCreatureWithType ct
entityFromRaw (Item it) = SomeEntity <$> Item.newWithType it
|
