create kithen cabinets on map

This commit is contained in:
nek0 2019-01-18 19:02:45 +01:00
parent 43e7a30ddc
commit cb923d4f21
5 changed files with 201 additions and 118 deletions

View file

@ -132,6 +132,7 @@ let
rev = "91c70c6ec62e407bd6d0233fbc2c64bafc3b6cdc"; rev = "91c70c6ec62e407bd6d0233fbc2c64bafc3b6cdc";
fetchSubmodules = true; fetchSubmodules = true;
}; };
configureFlags = [ "-fdebug" ];
isLibrary = true; isLibrary = true;
isExecutable = true; isExecutable = true;
libraryHaskellDepends = [ libraryHaskellDepends = [

View file

@ -43,9 +43,9 @@ traverseGraph imat acc (GHall sub) =
foldl (traverseGraph imat) acc sub foldl (traverseGraph imat) acc sub
traverseGraph imat (rng, putt) (GRoom _ bnds) = traverseGraph imat (rng, putt) (GRoom _ bnds) =
let applicable = let applicable =
L.sortBy (\b a -> size (a, (ph, pw)) `compare` size (b, (ph, pw))) ( L.sortBy (\b a -> size (a, (ph, pw), rng) `compare` size (b, (ph, pw), rng)) (
L.filter L.filter
(\a -> roomType `elem` clusterRoom a && size (a, (ph, pw)) <= size bnds) (\a -> roomType `elem` clusterRoom a && size (a, (ph, pw), rng) <= size bnds)
[minBound .. maxBound] :: [Cluster]) [minBound .. maxBound] :: [Cluster])
roomType = fst (L.minimumBy roomType = fst (L.minimumBy
(\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl (\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
@ -90,15 +90,11 @@ placeCluster imat rng bnds dim try mat rp appl =
(snd $ matmin bnds) (snd $ matmax bnds) (snd $ matmin bnds) (snd $ matmax bnds)
mat mat
) :: Int ) :: Int
cmat = clusterMat appl dim g2_2 (cmat, nrp) = clusterMatWithRPs appl dim g2_2
newmat = insertMat cmat mat (pr, pc) newmat = insertMat cmat mat (pr, pc)
exits = filter exits = filter
(\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds) (\p -> pointType p == RoomExit && inBounds (pointCoord p) bnds)
rp rp
reaches = map (+ V2 (pr - 1) (pc - 1))
(map pointCoord (clusterPoints appl dim))
reachdirs = map pointDir (clusterPoints appl dim)
reachtypes = map pointType (clusterPoints appl dim)
oldreaches = foldl (\acc p -> oldreaches = foldl (\acc p ->
if pointType p /= RoomExit && inBounds (pointCoord p) bnds if pointType p /= RoomExit && inBounds (pointCoord p) bnds
then pointCoord p : acc then pointCoord p : acc
@ -106,16 +102,20 @@ placeCluster imat rng bnds dim try mat rp appl =
) )
[] []
rp rp
reaches = (map (+ V2 (pr - 1) (pc - 1)) (map pointCoord nrp))
newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c) newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c)
(zip3 reachtypes reaches reachdirs) (zip3
(map pointType nrp)
reaches
(map pointDir nrp)
)
in in
if try >= 10 || fromIntegral freeRoom <= size (appl, dim) if try >= 10 || fromIntegral freeRoom <= size (appl, dim, g2)
then (g2, (mat, rp)) then (g2, (mat, rp))
else else
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 placeCluster imat g2 bnds dim (try + 1) mat rp appl
placeCluster imat g2 bnds dim (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
@ -129,21 +129,17 @@ placeCluster imat rng bnds dim try mat rp appl =
pc (pc + ncols cmat - 1) pc (pc + ncols cmat - 1)
mat mat
)) ))
then A.log A.Debug ("no cluster placed") $ then placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
placeCluster imat g2_1 bnds dim (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 placeCluster imat g2 bnds dim (try + 1) mat rp appl
placeCluster imat g2 bnds dim (try + 1) mat rp appl
else if else if
isReachable newmat [(V2 10 10, Boundaries (0, 1) (0, 1))] (oldreaches ++ reaches) exits isReachable newmat [(V2 10 10, Boundaries (0, 1) (0, 1))] (oldreaches ++ reaches) exits
then A.log A.Debug ("placed cluster" ++ show appl) $ then placeCluster imat g2_1 bnds dim (try + 1) newmat newrp appl
placeCluster imat g2_1 bnds dim (try + 1) newmat newrp appl else placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
else A.log A.Debug ("no cluster placed") $
placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
insertMat insertMat
:: Matrix (Maybe a) :: Matrix (Maybe a)

View file

@ -272,7 +272,7 @@ loadFork ws win glc nvg future progress = do
, mmiscFlipchart , mmiscFlipchart
, mmiscPlant1, mmiscPlant2 , mmiscPlant1, mmiscPlant2
, mmiscWatercooler, mmiscVending , mmiscWatercooler, mmiscVending
, mcabCoffeeSW, mcabCoffeSE , mcabCoffeeSW, mcabCoffeeSE
, mcabSinkSW, mcabSinkSE , mcabSinkSW, mcabSinkSE
, mcabStoveSW, mcabStoveSE , mcabStoveSW, mcabStoveSE
, mcabinetSW, mcabinetSE, mcabinetCorner , mcabinetSW, mcabinetSE, mcabinetCorner

View file

@ -128,7 +128,7 @@ loadMapFork ud ad future progress = do
( p + increment ( p + increment
, "Placing furniture" , "Placing furniture"
))) )))
(inter, rawrps) <- placeInteriorIO mat imgmat exits gr (!inter, !rawrps) <- placeInteriorIO mat imgmat exits gr
let !rps = ReachPoint Elevator (fcElevator fc) SE : rawrps let !rps = ReachPoint Elevator (fcElevator fc) SE : rawrps
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment

View file

@ -1,10 +1,14 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Types.Interior where module Types.Interior where
import qualified Affection as A
import Data.Matrix as M import Data.Matrix as M
import Linear.V2 import Linear.V2
import System.Random (StdGen, randomR)
-- internal imports -- internal imports
import Types.Map import Types.Map
@ -12,6 +16,7 @@ import Types.ReachPoint
import Types.ImgId import Types.ImgId
import Types.Direction import Types.Direction
data Cluster data Cluster
= ClusterBox1 = ClusterBox1
| ClusterTableSW | ClusterTableSW
@ -28,101 +33,185 @@ data Cluster
| ClusterToilet | ClusterToilet
| ClusterWatercooler | ClusterWatercooler
| ClusterVending | ClusterVending
| ClusterCabCoffee | ClusterCabinets
deriving (Enum, Bounded, Show) deriving (Enum, Bounded, Show)
-- row -> NS; col -> WE -- row -> NS; col -> WE
clusterMat :: Cluster -> (Int, Int) -> Matrix (Maybe ImgId) clusterMatWithRPs :: Cluster -> (Int, Int) -> StdGen -> (Matrix (Maybe ImgId), [ReachPoint])
clusterMat ClusterBox1 _ = clusterMatWithRPs ClusterBox1 dim _ =
M.fromLists ( M.fromLists
[ [Just ImgMiscBox1] [ [Just ImgMiscBox1]
] ]
clusterMat ClusterTableSW (h, _) = , clusterPoints ClusterBox1 dim
M.fromLists $ replicate h )
[Just ImgEmpty, Just ImgTableSW] clusterMatWithRPs ClusterTableSW dim@(h, _) _ =
clusterMat ClusterTableSE (_, w) = ( M.fromLists $ replicate h
M.fromLists $ [Just ImgEmpty, Just ImgTableSW]
[ replicate w (Just ImgTableSE) , clusterPoints ClusterTableSW dim
, replicate w (Just ImgEmpty) )
] clusterMatWithRPs ClusterTableSE dim@(_, w) _ =
clusterMat ClusterTableNE (h, _) = ( M.fromLists $
M.fromLists $ replicate h [ replicate w (Just ImgTableSE)
[Just ImgTableNE, Just ImgEmpty] , replicate w (Just ImgEmpty)
clusterMat ClusterTableNW (_, w) = ]
M.fromLists $ , clusterPoints ClusterTableSE dim
[ replicate w (Just ImgEmpty) )
, replicate w (Just ImgTableNW) clusterMatWithRPs ClusterTableNE dim@(h, _) _ =
] ( M.fromLists $ replicate h
clusterMat ClusterCornerTable _ = [Just ImgTableNE, Just ImgEmpty]
M.fromLists , clusterPoints ClusterTableNE dim
[ [Just ImgTableSE, Just ImgTableCorner] )
, [Just ImgEmpty, Just ImgTableSW] clusterMatWithRPs ClusterTableNW dim@(_, w) _ =
] ( M.fromLists $
clusterMat ClusterTableGroup _ = [ replicate w (Just ImgEmpty)
M.fromLists , replicate w (Just ImgTableNW)
[ [ Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner ]
, Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner , clusterPoints ClusterTableNW dim
] )
, [ Just ImgEmpty, Just ImgEmpty, Just ImgTableSW clusterMatWithRPs ClusterCornerTable dim _ =
, Just ImgEmpty, Just ImgEmpty, Just ImgTableSW ( M.fromLists
] [ [Just ImgTableSE, Just ImgTableCorner]
, [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty , [Just ImgEmpty, Just ImgTableSW]
, Just ImgEmpty, Just ImgEmpty, Just ImgEmpty ]
] , clusterPoints ClusterCornerTable dim
, [ Nothing, Nothing, Nothing )
, Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner clusterMatWithRPs ClusterTableGroup dim _ =
] ( M.fromLists
, [ Nothing, Nothing, Nothing [ [ Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
, Just ImgEmpty, Just ImgEmpty, Just ImgTableSW , Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
] ]
] , [ Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
clusterMat ClusterCopier _ = , Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
M.fromLists ]
[ [ Just ImgEmptyNoWalk] , [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
, [ Just ImgEmpty] , Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
] ]
clusterMat ClusterFlipchart _ = , [ Nothing, Nothing, Nothing
M.fromLists , Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
[ [ Just ImgMiscFlipchart] ]
, [ Just ImgEmpty] , [ Nothing, Nothing, Nothing
] , Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
clusterMat ClusterConferenceTable (h, w) = ]
]
, clusterPoints ClusterTableGroup dim
)
clusterMatWithRPs ClusterCopier dim _ =
( M.fromLists
[ [ Just ImgEmptyNoWalk]
, [ Just ImgEmpty]
]
, clusterPoints ClusterCopier dim
)
clusterMatWithRPs ClusterFlipchart dim _ =
( M.fromLists
[ [ Just ImgMiscFlipchart]
, [ Just ImgEmpty]
]
, clusterPoints ClusterFlipchart dim
)
clusterMatWithRPs ClusterConferenceTable dim@(h, w) _ =
let mw = max 4 w let mw = max 4 w
mh = max 4 h mh = max 4 h
in M.fromLists $ in
[ replicate mw (Just ImgEmpty) ( M.fromLists $
, [ Just ImgEmpty, Just ImgTableC4] ++ replicate (mw-4) (Just ImgTableNW) ++ [ replicate mw (Just ImgEmpty)
[ Just ImgTableC3, Just ImgEmpty ] , [ Just ImgEmpty, Just ImgTableC4] ++ replicate (mw-4) (Just ImgTableNW) ++
] ++ [ Just ImgTableC3, Just ImgEmpty ]
replicate (mh-4) ([ Just ImgEmpty, Just ImgTableSW] ++ replicate (mw-4) (Just ImgEmpty) ++ ] ++
[ Just ImgTableNE, Just ImgEmpty ]) ++ replicate (mh-4) ([ Just ImgEmpty, Just ImgTableSW] ++ replicate (mw-4) (Just ImgEmpty) ++
[ [ Just ImgEmpty, Just ImgTableC1] ++ replicate (mw-4) (Just ImgTableSE) ++ [ Just ImgTableNE, Just ImgEmpty ]) ++
[ Just ImgTableC2, Just ImgEmpty ] [ [ Just ImgEmpty, Just ImgTableC1] ++ replicate (mw-4) (Just ImgTableSE) ++
, replicate mw (Just ImgEmpty) [ Just ImgTableC2, Just ImgEmpty ]
] , replicate mw (Just ImgEmpty)
clusterMat ClusterPlant1 _ = ]
M.fromLists , clusterPoints ClusterConferenceTable dim
[ [ Just ImgMiscPlant1 ] ] )
clusterMat ClusterPlant2 _ = clusterMatWithRPs ClusterPlant1 dim _ =
M.fromLists ( M.fromLists
[ [ Just ImgMiscPlant2 ] ] [ [ Just ImgMiscPlant1 ] ]
clusterMat ClusterToilet _ = , clusterPoints ClusterPlant1 dim
M.fromLists )
[ [ Just ImgEmpty, Just ImgEmptyNoWalk] ] clusterMatWithRPs ClusterPlant2 dim _ =
clusterMat ClusterWatercooler _ = ( M.fromLists
M.fromLists [ [ Just ImgMiscPlant2 ] ]
[ [ Just ImgMiscWatercooler ] , clusterPoints ClusterPlant2 dim
, [ Just ImgEmpty ] )
] clusterMatWithRPs ClusterToilet dim _ =
clusterMat ClusterVending _ = ( M.fromLists
M.fromLists [ [ Just ImgEmpty, Just ImgEmptyNoWalk] ]
[ [ Just ImgMiscVending ] , clusterPoints ClusterToilet dim
, [ Just ImgEmpty ] )
] clusterMatWithRPs ClusterWatercooler dim _ =
clusterMat ClusterCabCoffee _ = ( M.fromLists
M.fromLists [ [ Just ImgMiscWatercooler ]
[ [ Just ImgEmpty, Just ImgCabinetCoffee ] , [ Just ImgEmpty ]
] ]
, clusterPoints ClusterWatercooler dim
)
clusterMatWithRPs ClusterVending dim _ =
( M.fromLists
[ [ Just ImgMiscVending ]
, [ Just ImgEmpty ]
]
, clusterPoints ClusterVending dim
)
clusterMatWithRPs ClusterCabinets dim@(h, w) g =
let iw = max 2 w
ih = max 2 h
rw = min 5 iw
rh = min 5 ih
selses =
[ ImgCabinetCoffeeSE
, ImgCabinetSinkSE
, ImgCabinetStoveSE
]
selsws =
[ ImgCabinetCoffeeSW
, ImgCabinetSinkSW
, ImgCabinetStoveSW
]
(g1, ses, seps) = foldl
(\(gen, lsi, lsr) a ->
let (switch, gf1) = randomR (1, 3) gen :: (Int, StdGen)
in if switch == 1
then
let (typ, gf2) = randomR (0, length selses - 1) gf1
img = selses !! typ
rp i
| i == ImgCabinetCoffeeSE = ReachPoint Drink (V2 2 a) NW
| i == ImgCabinetSinkSE = ReachPoint Drink (V2 2 a) NW
| i == ImgCabinetStoveSE = ReachPoint Eat (V2 2 a) NW
in (gf2, Just img : lsi, rp img : lsr)
else
(gf1, Just ImgCabinetSE : lsi, lsr)
)
(g, [], [])
(reverse [1 .. rw - 1])
(g2, sws, swps) = foldl
(\(gen, lsi, lsr) a ->
let (switch, gf1) = randomR (1, 3) gen :: (Int, StdGen)
in if switch == 1
then
let (typ, gf2) = randomR (0, length selsws - 1) gf1
img = selsws !! typ
rp i
| i == ImgCabinetCoffeeSW = ReachPoint Drink (V2 a (rw - 1)) NE
| i == ImgCabinetSinkSW = ReachPoint Drink (V2 a (rw - 1)) NE
| i == ImgCabinetStoveSW = ReachPoint Eat (V2 a (rw - 1)) NE
in (gf2, Just img : lsi, rp img : lsr)
else
(gf1, Just ImgCabinetSW : lsi, lsr)
)
(g1, [], [])
(reverse [1 .. rh - 1])
outmat =
(M.fromLists [ses] M.<|> M.fromLists [[ Just ImgCabinetCorner ]])
M.<->
(M.fromList (rh - 1) (rw - 1) (repeat $ Just ImgEmpty)
M.<|>
M.fromLists (map (\a -> [a]) sws)
)
in (outmat, (seps ++ swps))
clusterRoom :: Cluster -> [TileState] clusterRoom :: Cluster -> [TileState]
clusterRoom ClusterBox1 = [Offi] clusterRoom ClusterBox1 = [Offi]
@ -140,7 +229,7 @@ clusterRoom ClusterPlant2 = [Offi]
clusterRoom ClusterToilet = [Toil] clusterRoom ClusterToilet = [Toil]
clusterRoom ClusterWatercooler = [Kitc, Offi] clusterRoom ClusterWatercooler = [Kitc, Offi]
clusterRoom ClusterVending = [Kitc] clusterRoom ClusterVending = [Kitc]
clusterRoom ClusterCabCoffee = [Kitc] clusterRoom ClusterCabinets = [Kitc]
clusterPoints :: Cluster -> (Int, Int) -> [ReachPoint] clusterPoints :: Cluster -> (Int, Int) -> [ReachPoint]
clusterPoints ClusterBox1 _ = [] clusterPoints ClusterBox1 _ = []
@ -183,12 +272,9 @@ clusterPoints ClusterWatercooler _ =
clusterPoints ClusterVending _ = clusterPoints ClusterVending _ =
[ ReachPoint Eat (V2 2 1) NW [ ReachPoint Eat (V2 2 1) NW
] ]
clusterPoints ClusterCabCoffee _ =
[ ReachPoint Drink (V2 1 1) NE
]
clusterPoints _ _ = [] clusterPoints _ _ = []
instance Size (Cluster, (Int, Int)) where instance Size (Cluster, (Int, Int), StdGen) where
size (c, dim) = size (c, dim, gen) =
let mat = clusterMat c dim let mat = fst $ clusterMatWithRPs c dim gen
in fromIntegral ((nrows mat) * (ncols mat)) in fromIntegral ((nrows mat) * (ncols mat))