tracer/src/Interior.hs

111 lines
3.3 KiB
Haskell
Raw Normal View History

2018-03-03 16:03:17 +00:00
module Interior where
import Affection as A
import Data.Matrix as M
import qualified Data.Map.Strict as Map
import Data.List as L
import Data.Maybe (isNothing, isJust)
import System.Random
-- internal imports
import Types.Interior
import Types.Map
import Types.UserData
2018-03-03 16:42:24 +00:00
placeInteriorIO
:: Matrix TileState
-> Matrix (Maybe ImgId)
-> [Graph]
-> IO (Matrix (Maybe ImgId))
placeInteriorIO imat imgmat graph =
2018-03-03 16:03:17 +00:00
do
rnd <- newStdGen
let (_, mat) =
foldl
traverseGraph
2018-03-03 16:42:24 +00:00
(rnd, imgmat)
2018-03-03 16:03:17 +00:00
graph
return mat
where
traverseGraph
:: (StdGen, Matrix (Maybe ImgId))
-> Graph
-> (StdGen, Matrix (Maybe ImgId))
traverseGraph acc (GHall sub) =
foldl traverseGraph acc sub
traverseGraph put@(rng, mat) (GRoom _ bnds) =
let applicable =
reverse (L.sortBy (\a b -> size a `compare` size b) (
L.filter
(\a -> clusterRoom a == roomType && size a < size bnds)
[minBound .. maxBound] :: [Cluster])
)
roomType = fst (head $ reverse $ L.sortBy
(\a b -> snd a `compare` snd b) $ 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
)
)
in
foldl (\(orng, omat) -> placeCluster orng bnds 1 omat) put applicable
placeCluster rng bnds try mat appl =
2018-03-03 16:42:24 +00:00
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
2018-03-03 16:03:17 +00:00
freeRoom = foldl
(\acc a -> if a == Nothing then acc + 1 else acc)
0
(M.toList $ M.submatrix
(fst $ matmin bnds) (fst $ matmax bnds)
(snd $ matmin bnds) (snd $ matmax bnds)
mat
)
cmat = clusterMat appl
in
if try > 100 || fromIntegral freeRoom < size appl
then (g2, mat)
else
2018-03-03 16:42:24 +00:00
if pr + nrows cmat - 1 > fst (matmax bnds) ||
pc + ncols cmat - 1 > snd (matmax bnds) ||
2018-03-03 16:03:17 +00:00
any (/= clusterRoom appl)
(M.toList (M.submatrix
2018-03-03 16:42:24 +00:00
pr (pr + nrows cmat - 1)
pc (pc + ncols cmat - 1)
2018-03-03 16:03:17 +00:00
imat
)) ||
any isJust
(M.toList (M.submatrix
2018-03-03 16:42:24 +00:00
pr (pr + nrows cmat - 1)
pc (pc + ncols cmat - 1)
2018-03-03 16:03:17 +00:00
mat
))
then placeCluster g2 bnds (try + 1) mat appl
2018-03-03 16:42:24 +00:00
else placeCluster
g2 bnds (try + 1) (insertMat cmat mat (pr, pc)) appl
2018-03-03 16:03:17 +00:00
insertMat
:: Matrix (Maybe a)
-> Matrix (Maybe a)
-> (Int, Int)
-> Matrix (Maybe a)
insertMat i into (roffs, coffs) =
if roffs + nrows i > nrows into || coffs + ncols i > ncols into
then error "insertMat: matrix to be inserted does not fit!"
else foldl
(\mat (ir, ic) ->
2018-03-03 16:42:24 +00:00
if isNothing (mat M.! (ir + roffs - 1, ic + coffs - 1))
then M.setElem (i M.! (ir, ic)) (ir + roffs - 1, ic + coffs - 1) mat
2018-03-03 16:03:17 +00:00
else mat
)
into
((,) <$> [1 .. nrows i] <*> [1 .. ncols i])