2018-03-03 16:03:17 +00:00
|
|
|
module Interior where
|
|
|
|
|
|
|
|
import Data.Matrix as M
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import Data.List as L
|
|
|
|
import Data.Maybe (isNothing, isJust)
|
|
|
|
|
2018-04-02 14:29:35 +00:00
|
|
|
import Linear.V2
|
|
|
|
|
2018-03-03 16:03:17 +00:00
|
|
|
import System.Random
|
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
2018-04-02 14:29:35 +00:00
|
|
|
import Navigation
|
2018-04-14 11:34:28 +00:00
|
|
|
import Util
|
2018-04-02 14:29:35 +00:00
|
|
|
|
2018-06-04 03:29:20 +00:00
|
|
|
import Types
|
2018-03-03 16:03:17 +00:00
|
|
|
|
2018-03-03 16:42:24 +00:00
|
|
|
placeInteriorIO
|
|
|
|
:: Matrix TileState
|
|
|
|
-> Matrix (Maybe ImgId)
|
2018-04-02 14:29:35 +00:00
|
|
|
-> [ReachPoint]
|
2018-03-03 16:42:24 +00:00
|
|
|
-> [Graph]
|
2018-04-02 14:29:35 +00:00
|
|
|
-> IO (Matrix (Maybe ImgId), [ReachPoint])
|
|
|
|
placeInteriorIO imat imgmat irp graph =
|
2018-03-03 16:03:17 +00:00
|
|
|
do
|
|
|
|
rnd <- newStdGen
|
2018-04-02 14:29:35 +00:00
|
|
|
let (_, matps) =
|
2018-03-03 16:03:17 +00:00
|
|
|
foldl
|
|
|
|
traverseGraph
|
2018-04-02 14:29:35 +00:00
|
|
|
(rnd, (imgmat, irp))
|
2018-03-03 16:03:17 +00:00
|
|
|
graph
|
2018-04-02 14:29:35 +00:00
|
|
|
return matps
|
2018-03-03 16:03:17 +00:00
|
|
|
where
|
|
|
|
traverseGraph
|
2018-04-02 14:29:35 +00:00
|
|
|
:: (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
2018-03-03 16:03:17 +00:00
|
|
|
-> Graph
|
2018-04-02 14:29:35 +00:00
|
|
|
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
2018-03-03 16:03:17 +00:00
|
|
|
traverseGraph acc (GHall sub) =
|
|
|
|
foldl traverseGraph acc sub
|
2018-07-21 04:43:26 +00:00
|
|
|
traverseGraph putt (GRoom _ bnds) =
|
2018-03-03 16:03:17 +00:00
|
|
|
let applicable =
|
2018-09-02 08:44:33 +00:00
|
|
|
L.sortBy (\b a -> size a `compare` size b) (
|
2018-03-03 16:03:17 +00:00
|
|
|
L.filter
|
2018-07-31 11:30:17 +00:00
|
|
|
(\a -> roomType `elem` clusterRoom a && size a <= size bnds)
|
2018-03-03 16:03:17 +00:00
|
|
|
[minBound .. maxBound] :: [Cluster])
|
2018-09-02 08:44:33 +00:00
|
|
|
roomType = fst (L.minimumBy
|
2018-07-03 14:19:27 +00:00
|
|
|
(\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
|
2018-03-03 16:03:17 +00:00
|
|
|
(\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
|
2018-04-02 14:29:35 +00:00
|
|
|
foldl
|
|
|
|
(\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp)
|
2018-07-03 14:19:27 +00:00
|
|
|
putt
|
2018-04-02 14:29:35 +00:00
|
|
|
applicable
|
|
|
|
placeCluster
|
|
|
|
:: StdGen
|
|
|
|
-> Boundaries Int
|
|
|
|
-> Int
|
|
|
|
-> Matrix (Maybe ImgId)
|
|
|
|
-> [ReachPoint]
|
|
|
|
-> Cluster
|
|
|
|
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
|
|
|
|
placeCluster rng bnds try mat rp 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
|
2018-09-02 08:44:33 +00:00
|
|
|
(\acc a -> if isNothing a then acc + 1 else acc)
|
2018-03-03 16:03:17 +00:00
|
|
|
0
|
|
|
|
(M.toList $ M.submatrix
|
|
|
|
(fst $ matmin bnds) (fst $ matmax bnds)
|
|
|
|
(snd $ matmin bnds) (snd $ matmax bnds)
|
|
|
|
mat
|
2018-07-03 14:19:27 +00:00
|
|
|
) :: Int
|
2018-03-03 16:03:17 +00:00
|
|
|
cmat = clusterMat appl
|
2018-04-02 14:29:35 +00:00
|
|
|
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))
|
2018-06-04 03:29:20 +00:00
|
|
|
reachdirs = map pointDir (clusterPoints appl)
|
2018-07-21 04:43:26 +00:00
|
|
|
reachtypes = map pointType (clusterPoints appl)
|
2018-04-02 14:29:35 +00:00
|
|
|
oldreaches = foldl (\acc p ->
|
|
|
|
if pointType p /= RoomExit && inBounds (pointCoord p) bnds
|
|
|
|
then pointCoord p : acc
|
|
|
|
else acc
|
|
|
|
)
|
|
|
|
[]
|
|
|
|
rp
|
2018-07-21 04:43:26 +00:00
|
|
|
newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c)
|
|
|
|
(zip3 reachtypes reaches reachdirs)
|
2018-03-03 16:03:17 +00:00
|
|
|
in
|
2018-03-05 20:11:38 +00:00
|
|
|
if try > 10 || fromIntegral freeRoom < size appl
|
2018-04-02 14:29:35 +00:00
|
|
|
then (g2, (mat, rp))
|
2018-03-03 16:03:17 +00:00
|
|
|
else
|
2018-04-02 14:29:35 +00:00
|
|
|
if (pr + nrows cmat - 1 > fst (matmax bnds) ||
|
2018-09-19 18:19:01 +00:00
|
|
|
pc + ncols cmat - 1 > snd (matmax bnds) ||
|
|
|
|
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
|
|
|
|
))) ||
|
|
|
|
not (isReachable newmat [] (oldreaches ++ reaches) exits)
|
2018-04-02 14:29:35 +00:00
|
|
|
then placeCluster g2 bnds (try + 1) mat rp appl
|
2018-03-03 16:42:24 +00:00
|
|
|
else placeCluster
|
2018-04-02 14:29:35 +00:00
|
|
|
g2 bnds (try + 1) newmat newrp 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])
|