107 lines
3.4 KiB
Haskell
107 lines
3.4 KiB
Haskell
|
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
|
||
|
|
|
||
|
|
placeInteriorIO :: Matrix TileState -> [Graph] -> IO (Matrix (Maybe ImgId))
|
||
|
|
placeInteriorIO imat graph =
|
||
|
|
do
|
||
|
|
rnd <- newStdGen
|
||
|
|
let (_, mat) =
|
||
|
|
foldl
|
||
|
|
traverseGraph
|
||
|
|
(rnd, M.fromList (nrows imat) (ncols imat) (repeat Nothing))
|
||
|
|
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 =
|
||
|
|
let (pr, g1) = randomR (fst (matmin bnds), fst (matmax bnds)) rng
|
||
|
|
(pc, g2) = randomR (snd (matmin bnds), snd (matmax bnds)) g1
|
||
|
|
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
|
||
|
|
if pr - 1 + nrows cmat > fst (matmax bnds) ||
|
||
|
|
pc - 1 + ncols cmat > snd (matmax bnds) ||
|
||
|
|
any (/= clusterRoom appl)
|
||
|
|
(M.toList (M.submatrix
|
||
|
|
(pr - 1) (pr + nrows cmat - 1)
|
||
|
|
(pc - 1) (pc + ncols cmat - 1)
|
||
|
|
imat
|
||
|
|
)) ||
|
||
|
|
any isJust
|
||
|
|
(M.toList (M.submatrix
|
||
|
|
(pr - 1) (pr + nrows cmat - 1)
|
||
|
|
(pc - 1) (pc + ncols cmat - 1)
|
||
|
|
mat
|
||
|
|
))
|
||
|
|
then placeCluster g2 bnds (try + 1) mat appl
|
||
|
|
else A.log A.Debug ("Placing stuff at: " ++ show (pr - 1, pc - 1)) (placeCluster
|
||
|
|
g2 bnds (try + 1) (insertMat cmat mat (pr - 1, pc - 1)) appl)
|
||
|
|
|
||
|
|
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) ->
|
||
|
|
if isNothing (mat M.! (ir + roffs, ic + coffs))
|
||
|
|
then M.setElem (i M.! (ir, ic)) (ir + roffs, ic + coffs) mat
|
||
|
|
else mat
|
||
|
|
)
|
||
|
|
into
|
||
|
|
((,) <$> [1 .. nrows i] <*> [1 .. ncols i])
|