about summary refs log tree commit diff
path: root/src/Xanthous/Generators/LevelContents.hs
blob: 117860405ac3def0fbe9099f43ea0272272bd03d (plain) (blame)
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