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
|
module Xanthous.Generators.Village
( fromCave
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (any, failing, toList)
--------------------------------------------------------------------------------
import Control.Monad.Random (MonadRandom)
import Control.Monad.State (execStateT, MonadState, modify)
import Control.Monad.Trans.Maybe
import Control.Parallel.Strategies
import Data.Array.IArray
import Data.Foldable (any, toList)
--------------------------------------------------------------------------------
import Xanthous.Data
import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment
import Xanthous.Generators.Util
import Xanthous.Game.State (SomeEntity(..))
import Xanthous.Random
--------------------------------------------------------------------------------
fromCave :: MonadRandom m
=> Cells -- ^ The positions of all the walls
-> m (EntityMap SomeEntity)
fromCave wallPositions = execStateT (fromCave' wallPositions) mempty
fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m)
=> Cells
-> m ()
fromCave' wallPositions = failing (pure ()) $ do
Just villageRegion <-
choose
. (`using` parTraversable rdeepseq)
. weightedBy (\reg -> let circSize = length $ circumference reg
in if circSize == 50
then (1.0 :: Double)
else 1.0 / (fromIntegral . abs $ circSize - 50))
$ regions closedHallways
let circ = setFromList . circumference $ villageRegion
centerPoints <- chooseSubset (0.1 :: Double) $ toList circ
roomTiles <- foldM
(flip $ const $ stepOut circ)
(map pure centerPoints)
[0 :: Int ..2]
let roomWalls = circumference . setFromList @(Set _) <$> roomTiles
allWalls = join roomWalls
doorPositions <- fmap join . for roomWalls $ \room ->
let candidates = filter (`notMember` circ) room
in fmap toList . choose $ ChooseElement candidates
let entryways =
filter (\pt ->
let ncs = neighborCells pt
in any ((&&) <$> (not . (wallPositions !))
<*> (`notMember` villageRegion)) ncs
&& any ((&&) <$> (`member` villageRegion)
<*> (`notElem` allWalls)) ncs)
$ toList villageRegion
Just entryway <- choose $ ChooseElement entryways
for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls)
$ insertEntity Wall
for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor
insertEntity unlockedDoor entryway
where
insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e
ptToPos pt = _Position # (pt & both %~ fromIntegral)
stepOut :: Set (Word, Word) -> [[(Word, Word)]] -> MaybeT m [[(Word, Word)]]
stepOut circ rooms = for rooms $ \room ->
let nextLevels = hashNub $ toList . neighborCells =<< room
in pure
. (<> room)
$ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms))
nextLevels
circumference pts =
filter (any (`notMember` pts) . neighborCells) $ toList pts
closedHallways = closeHallways livePositions
livePositions = amap not wallPositions
--------------------------------------------------------------------------------
closeHallways :: Cells -> Cells
closeHallways livePositions =
livePositions // mapMaybe closeHallway (assocs livePositions)
where
closeHallway (_, False) = Nothing
closeHallway (pos, _)
| isHallway pos = Just (pos, False)
| otherwise = Nothing
isHallway pos = any ((&&) <$> not . view left <*> not . view right)
. rotations
. fmap (fromMaybe False)
$ arrayNeighbors livePositions pos
failing :: Monad m => m a -> MaybeT m a -> m a
failing result = (maybe result pure =<<) . runMaybeT
{-
import Xanthous.Generators.Village
import Xanthous.Generators
import Xanthous.Data
import System.Random
import qualified Data.Text
import qualified Xanthous.Generators.CaveAutomata as CA
let gi = GeneratorInput SCaveAutomata CA.defaultParams
wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen
putStrLn . Data.Text.unpack $ showCells wallPositions
import Data.Array.IArray
let closedHallways = closeHallways . amap not $ wallPositions
putStrLn . Data.Text.unpack . showCells $ amap not closedHallways
-}
|
