nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

split up

Browse source
This commit is contained in:
nek0 2018-11-13 00:56:04 +01:00
parent 617641ee7d
commit a991f2436b
1 changed files with 105 additions and 102 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
src/Interior.hs
View file

@ -29,18 +29,19 @@ placeInteriorIO imat imgmat irp graph =
rnd <- newStdGen rnd <- newStdGen
let (_, matps) = let (_, matps) =
foldl foldl
traverseGraph (traverseGraph imat)
(rnd, (imgmat, irp)) (rnd, (imgmat, irp))
graph graph
return matps return matps
where
traverseGraph traverseGraph
:: (StdGen, (Matrix (Maybe ImgId), [ReachPoint])) :: Matrix TileState
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
-> Graph -> Graph
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint])) -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
traverseGraph acc (GHall sub) = traverseGraph imat acc (GHall sub) =
foldl traverseGraph acc sub foldl (traverseGraph imat) acc sub
traverseGraph putt (GRoom _ bnds) = traverseGraph imat putt (GRoom _ bnds) =
let applicable = let applicable =
L.sortBy (\b a -> size a `compare` size b) ( L.sortBy (\b a -> size a `compare` size b) (
L.filter L.filter
@ -61,18 +62,20 @@ placeInteriorIO imat imgmat irp graph =
) )
in in
foldl foldl
(\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp) (\(orng, (omat, orp)) -> placeCluster imat orng bnds 1 omat orp)
putt putt
applicable applicable
placeCluster
:: StdGen placeCluster
:: Matrix TileState
-> StdGen
-> Boundaries Int -> Boundaries Int
-> Int -> Int
-> Matrix (Maybe ImgId) -> Matrix (Maybe ImgId)
-> [ReachPoint] -> [ReachPoint]
-> Cluster -> Cluster
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint])) -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
placeCluster rng bnds try mat rp appl = placeCluster imat rng bnds try mat rp appl =
let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng 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 (pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
freeRoom = foldl freeRoom = foldl
@ -108,7 +111,7 @@ placeInteriorIO imat imgmat irp graph =
if pr + nrows cmat - 1 > fst (matmax bnds) || if pr + nrows cmat - 1 > fst (matmax bnds) ||
pc + ncols cmat - 1 > snd (matmax bnds) pc + ncols cmat - 1 > snd (matmax bnds)
then A.log A.Debug ("no cluster placed") $ 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 else if
any (`notElem` clusterRoom appl) any (`notElem` clusterRoom appl)
(M.toList (M.submatrix (M.toList (M.submatrix
@ -123,20 +126,20 @@ placeInteriorIO imat imgmat irp graph =
mat mat
)) ))
then A.log A.Debug ("no cluster placed") $ 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 else if
any (`elem` (oldreaches)) any (`elem` (oldreaches))
(V2 (V2
<$> [pr .. pr + nrows cmat - 1] <$> [pr .. pr + nrows cmat - 1]
<*> [pc .. pc + ncols cmat - 1]) <*> [pc .. pc + ncols cmat - 1])
then A.log A.Debug ("no cluster placed") $ 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 else if
not (isReachable newmat [] (oldreaches ++ reaches) exits) isReachable newmat [(V2 10 10, Boundaries (0, 1) (0, 1))] (oldreaches ++ reaches) exits
then A.log A.Debug ("no cluster placed") $ then A.log A.Debug ("placed cluster" ++ show appl) $
placeCluster g2 bnds (try + 1) mat rp appl placeCluster imat g2 bnds (try + 1) newmat newrp appl
else A.log A.Debug ("placed cluster" ++ show appl) $ else A.log A.Debug ("no cluster placed") $
placeCluster g2 bnds (try + 1) newmat newrp appl placeCluster imat g2 bnds (try + 1) mat rp appl
insertMat insertMat
:: Matrix (Maybe a) :: Matrix (Maybe a)