tracer/src/Interior.hs

141 lines
4.4 KiB
Haskell
Raw Normal View History

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)
import Linear.V2
2018-03-03 16:03:17 +00:00
import System.Random
-- internal imports
import Navigation
2018-04-14 11:34:28 +00:00
import Util
import Types
2018-03-03 16:03:17 +00:00
2018-03-03 16:42:24 +00:00
placeInteriorIO
:: Matrix TileState
-> Matrix (Maybe ImgId)
-> [ReachPoint]
2018-03-03 16:42:24 +00:00
-> [Graph]
-> IO (Matrix (Maybe ImgId), [ReachPoint])
placeInteriorIO imat imgmat irp graph =
2018-03-03 16:03:17 +00:00
do
rnd <- newStdGen
let (_, matps) =
2018-03-03 16:03:17 +00:00
foldl
traverseGraph
(rnd, (imgmat, irp))
2018-03-03 16:03:17 +00:00
graph
return matps
2018-03-03 16:03:17 +00:00
where
traverseGraph
:: (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
2018-03-03 16:03:17 +00:00
-> Graph
-> (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
foldl
(\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp)
2018-07-03 14:19:27 +00:00
putt
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
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)
2018-07-21 04:43:26 +00:00
reachtypes = map pointType (clusterPoints appl)
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
then (g2, (mat, rp))
2018-03-03 16:03:17 +00:00
else
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)
then placeCluster g2 bnds (try + 1) mat rp appl
2018-03-03 16:42:24 +00:00
else placeCluster
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])