This commit is contained in:
nek0 2018-11-13 00:56:04 +01:00
parent 617641ee7d
commit a991f2436b

View file

@ -29,114 +29,117 @@ placeInteriorIO imat imgmat irp graph =
rnd <- newStdGen
let (_, matps) =
foldl
traverseGraph
(traverseGraph imat)
(rnd, (imgmat, irp))
graph
return matps
where
traverseGraph
:: (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
-> Graph
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
traverseGraph acc (GHall sub) =
foldl traverseGraph acc sub
traverseGraph putt (GRoom _ bnds) =
let applicable =
L.sortBy (\b a -> size a `compare` size b) (
L.filter
(\a -> roomType `elem` clusterRoom a && size a <= size bnds)
[minBound .. maxBound] :: [Cluster])
roomType = fst (L.minimumBy
(\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
(\acc a -> if a `Map.member` 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
)
traverseGraph
:: Matrix TileState
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
-> Graph
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
traverseGraph imat acc (GHall sub) =
foldl (traverseGraph imat) acc sub
traverseGraph imat putt (GRoom _ bnds) =
let applicable =
L.sortBy (\b a -> size a `compare` size b) (
L.filter
(\a -> roomType `elem` clusterRoom a && size a <= size bnds)
[minBound .. maxBound] :: [Cluster])
roomType = fst (L.minimumBy
(\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
(\acc a -> if a `Map.member` acc
then Map.insert a (acc Map.! a + 1) acc
else Map.insert a 1 acc
)
in
foldl
(\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp)
putt
applicable
placeCluster
:: StdGen
-> Boundaries Int
-> Int
-> Matrix (Maybe ImgId)
-> [ReachPoint]
-> Cluster
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
placeCluster rng bnds try mat rp appl =
let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng
(pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
freeRoom = foldl
(\acc a -> if isNothing a then acc + 1 else acc)
0
(M.toList $ M.submatrix
(fst $ matmin bnds) (fst $ matmax bnds)
(snd $ matmin bnds) (snd $ matmax bnds)
mat
) :: Int
cmat = clusterMat appl
newmat = insertMat cmat mat (pr, pc)
exits = filter
(\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds)
rp
reaches = map (+ V2 (pr - 1) (pc - 1))
(map pointCoord (clusterPoints appl))
reachdirs = map pointDir (clusterPoints appl)
reachtypes = map pointType (clusterPoints appl)
oldreaches = foldl (\acc p ->
if pointType p /= RoomExit && inBounds (pointCoord p) bnds
then pointCoord p : acc
else acc
)
[]
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)
Map.empty
(M.submatrix
(fst $ matmin bnds) (fst $ matmax bnds)
(snd $ matmin bnds) (snd $ matmax bnds)
imat
)
)
in
foldl
(\(orng, (omat, orp)) -> placeCluster imat orng bnds 1 omat orp)
putt
applicable
placeCluster
:: Matrix TileState
-> StdGen
-> Boundaries Int
-> Int
-> Matrix (Maybe ImgId)
-> [ReachPoint]
-> Cluster
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
placeCluster imat rng bnds try mat rp appl =
let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng
(pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
freeRoom = foldl
(\acc a -> if isNothing a then acc + 1 else acc)
0
(M.toList $ M.submatrix
(fst $ matmin bnds) (fst $ matmax bnds)
(snd $ matmin bnds) (snd $ matmax bnds)
mat
) :: Int
cmat = clusterMat appl
newmat = insertMat cmat mat (pr, pc)
exits = filter
(\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds)
rp
reaches = map (+ V2 (pr - 1) (pc - 1))
(map pointCoord (clusterPoints appl))
reachdirs = map pointDir (clusterPoints appl)
reachtypes = map pointType (clusterPoints appl)
oldreaches = foldl (\acc p ->
if pointType p /= RoomExit && inBounds (pointCoord p) bnds
then pointCoord p : acc
else acc
)
[]
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") $
placeCluster g2 bnds (try + 1) mat rp appl
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 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
isReachable newmat [(V2 10 10, Boundaries (0, 1) (0, 1))] (oldreaches ++ reaches) exits
then A.log A.Debug ("placed cluster" ++ show appl) $
placeCluster imat g2 bnds (try + 1) newmat newrp appl
else A.log A.Debug ("no cluster placed") $
placeCluster imat g2 bnds (try + 1) mat rp appl
insertMat
:: Matrix (Maybe a)