split up
This commit is contained in:
nek0
parent
617641ee7d
commit
a991f2436b
1 changed files with 105 additions and 102 deletions
207
src/Interior.hs
207
src/Interior.hs
|
|
@ -29,114 +29,117 @@ placeInteriorIO imat imgmat irp graph =
|
||||||
rnd <- newStdGen
|
rnd <- newStdGen
|
||||||
let (_, matps) =
|
let (_, matps) =
|
||||||
foldl
|
foldl
|
||||||
traverseGraph
|
(traverseGraph imat)
|
||||||
(rnd, (imgmat, irp))
|
(rnd, (imgmat, irp))
|
||||||
graph
|
graph
|
||||||
return matps
|
return matps
|
||||||
where
|
|
||||||
traverseGraph
|
traverseGraph
|
||||||
:: (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
:: Matrix TileState
|
||||||
-> Graph
|
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
||||||
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
-> Graph
|
||||||
traverseGraph acc (GHall sub) =
|
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
||||||
foldl traverseGraph acc sub
|
traverseGraph imat acc (GHall sub) =
|
||||||
traverseGraph putt (GRoom _ bnds) =
|
foldl (traverseGraph imat) acc sub
|
||||||
let applicable =
|
traverseGraph imat putt (GRoom _ bnds) =
|
||||||
L.sortBy (\b a -> size a `compare` size b) (
|
let applicable =
|
||||||
L.filter
|
L.sortBy (\b a -> size a `compare` size b) (
|
||||||
(\a -> roomType `elem` clusterRoom a && size a <= size bnds)
|
L.filter
|
||||||
[minBound .. maxBound] :: [Cluster])
|
(\a -> roomType `elem` clusterRoom a && size a <= size bnds)
|
||||||
roomType = fst (L.minimumBy
|
[minBound .. maxBound] :: [Cluster])
|
||||||
(\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
|
roomType = fst (L.minimumBy
|
||||||
(\acc a -> if a `Map.member` acc
|
(\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
|
||||||
then Map.insert a (acc Map.! a + 1) acc
|
(\acc a -> if a `Map.member` acc
|
||||||
else Map.insert a 1 acc
|
then Map.insert a (acc Map.! a + 1) acc
|
||||||
)
|
else Map.insert a 1 acc
|
||||||
Map.empty
|
|
||||||
(M.submatrix
|
|
||||||
(fst $ matmin bnds) (fst $ matmax bnds)
|
|
||||||
(snd $ matmin bnds) (snd $ matmax bnds)
|
|
||||||
imat
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
in
|
Map.empty
|
||||||
foldl
|
(M.submatrix
|
||||||
(\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp)
|
(fst $ matmin bnds) (fst $ matmax bnds)
|
||||||
putt
|
(snd $ matmin bnds) (snd $ matmax bnds)
|
||||||
applicable
|
imat
|
||||||
placeCluster
|
)
|
||||||
:: StdGen
|
)
|
||||||
-> Boundaries Int
|
in
|
||||||
-> Int
|
foldl
|
||||||
-> Matrix (Maybe ImgId)
|
(\(orng, (omat, orp)) -> placeCluster imat orng bnds 1 omat orp)
|
||||||
-> [ReachPoint]
|
putt
|
||||||
-> Cluster
|
applicable
|
||||||
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
|
||||||
placeCluster rng bnds try mat rp appl =
|
placeCluster
|
||||||
let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng
|
:: Matrix TileState
|
||||||
(pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
|
-> StdGen
|
||||||
freeRoom = foldl
|
-> Boundaries Int
|
||||||
(\acc a -> if isNothing a then acc + 1 else acc)
|
-> Int
|
||||||
0
|
-> Matrix (Maybe ImgId)
|
||||||
(M.toList $ M.submatrix
|
-> [ReachPoint]
|
||||||
(fst $ matmin bnds) (fst $ matmax bnds)
|
-> Cluster
|
||||||
(snd $ matmin bnds) (snd $ matmax bnds)
|
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
||||||
mat
|
placeCluster imat rng bnds try mat rp appl =
|
||||||
) :: Int
|
let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng
|
||||||
cmat = clusterMat appl
|
(pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
|
||||||
newmat = insertMat cmat mat (pr, pc)
|
freeRoom = foldl
|
||||||
exits = filter
|
(\acc a -> if isNothing a then acc + 1 else acc)
|
||||||
(\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds)
|
0
|
||||||
rp
|
(M.toList $ M.submatrix
|
||||||
reaches = map (+ V2 (pr - 1) (pc - 1))
|
(fst $ matmin bnds) (fst $ matmax bnds)
|
||||||
(map pointCoord (clusterPoints appl))
|
(snd $ matmin bnds) (snd $ matmax bnds)
|
||||||
reachdirs = map pointDir (clusterPoints appl)
|
mat
|
||||||
reachtypes = map pointType (clusterPoints appl)
|
) :: Int
|
||||||
oldreaches = foldl (\acc p ->
|
cmat = clusterMat appl
|
||||||
if pointType p /= RoomExit && inBounds (pointCoord p) bnds
|
newmat = insertMat cmat mat (pr, pc)
|
||||||
then pointCoord p : acc
|
exits = filter
|
||||||
else acc
|
(\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds)
|
||||||
)
|
rp
|
||||||
[]
|
reaches = map (+ V2 (pr - 1) (pc - 1))
|
||||||
rp
|
(map pointCoord (clusterPoints appl))
|
||||||
newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c)
|
reachdirs = map pointDir (clusterPoints appl)
|
||||||
(zip3 reachtypes reaches reachdirs)
|
reachtypes = map pointType (clusterPoints appl)
|
||||||
in
|
oldreaches = foldl (\acc p ->
|
||||||
if try >= 10 || fromIntegral freeRoom <= size appl
|
if pointType p /= RoomExit && inBounds (pointCoord p) bnds
|
||||||
then (g2, (mat, rp))
|
then pointCoord p : acc
|
||||||
else
|
else acc
|
||||||
if pr + nrows cmat - 1 > fst (matmax bnds) ||
|
)
|
||||||
pc + ncols cmat - 1 > snd (matmax bnds)
|
[]
|
||||||
|
rp
|
||||||
|
newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c)
|
||||||
|
(zip3 reachtypes reaches reachdirs)
|
||||||
|
in
|
||||||
|
if try >= 10 || fromIntegral freeRoom <= size appl
|
||||||
|
then (g2, (mat, rp))
|
||||||
|
else
|
||||||
|
if pr + nrows cmat - 1 > fst (matmax bnds) ||
|
||||||
|
pc + ncols cmat - 1 > snd (matmax bnds)
|
||||||
|
then A.log A.Debug ("no cluster placed") $
|
||||||
|
placeCluster imat g2 bnds (try + 1) mat rp appl
|
||||||
|
else if
|
||||||
|
any (`notElem` clusterRoom appl)
|
||||||
|
(M.toList (M.submatrix
|
||||||
|
pr (pr + nrows cmat - 1)
|
||||||
|
pc (pc + ncols cmat - 1)
|
||||||
|
imat
|
||||||
|
)) ||
|
||||||
|
any isJust
|
||||||
|
(M.toList (M.submatrix
|
||||||
|
pr (pr + nrows cmat - 1)
|
||||||
|
pc (pc + ncols cmat - 1)
|
||||||
|
mat
|
||||||
|
))
|
||||||
|
then A.log A.Debug ("no cluster placed") $
|
||||||
|
placeCluster imat g2 bnds (try + 1) mat rp appl
|
||||||
|
else if
|
||||||
|
any (`elem` (oldreaches))
|
||||||
|
(V2
|
||||||
|
<$> [pr .. pr + nrows cmat - 1]
|
||||||
|
<*> [pc .. pc + ncols cmat - 1])
|
||||||
then A.log A.Debug ("no cluster placed") $
|
then A.log A.Debug ("no cluster placed") $
|
||||||
placeCluster g2 bnds (try + 1) mat rp appl
|
placeCluster imat g2 bnds (try + 1) mat rp appl
|
||||||
else if
|
else if
|
||||||
any (`notElem` clusterRoom appl)
|
isReachable newmat [(V2 10 10, Boundaries (0, 1) (0, 1))] (oldreaches ++ reaches) exits
|
||||||
(M.toList (M.submatrix
|
then A.log A.Debug ("placed cluster" ++ show appl) $
|
||||||
pr (pr + nrows cmat - 1)
|
placeCluster imat g2 bnds (try + 1) newmat newrp appl
|
||||||
pc (pc + ncols cmat - 1)
|
else A.log A.Debug ("no cluster placed") $
|
||||||
imat
|
placeCluster imat g2 bnds (try + 1) mat rp appl
|
||||||
)) ||
|
|
||||||
any isJust
|
|
||||||
(M.toList (M.submatrix
|
|
||||||
pr (pr + nrows cmat - 1)
|
|
||||||
pc (pc + ncols cmat - 1)
|
|
||||||
mat
|
|
||||||
))
|
|
||||||
then A.log A.Debug ("no cluster placed") $
|
|
||||||
placeCluster g2 bnds (try + 1) mat rp appl
|
|
||||||
else if
|
|
||||||
any (`elem` (oldreaches))
|
|
||||||
(V2
|
|
||||||
<$> [pr .. pr + nrows cmat - 1]
|
|
||||||
<*> [pc .. pc + ncols cmat - 1])
|
|
||||||
then A.log A.Debug ("no cluster placed") $
|
|
||||||
placeCluster g2 bnds (try + 1) mat rp appl
|
|
||||||
else if
|
|
||||||
not (isReachable newmat [] (oldreaches ++ reaches) exits)
|
|
||||||
then A.log A.Debug ("no cluster placed") $
|
|
||||||
placeCluster g2 bnds (try + 1) mat rp appl
|
|
||||||
else A.log A.Debug ("placed cluster" ++ show appl) $
|
|
||||||
placeCluster g2 bnds (try + 1) newmat newrp appl
|
|
||||||
|
|
||||||
insertMat
|
insertMat
|
||||||
:: Matrix (Maybe a)
|
:: Matrix (Maybe a)
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue