create kithen cabinets on map
This commit is contained in:
nek0
parent
43e7a30ddc
commit
cb923d4f21
5 changed files with 201 additions and 118 deletions
|
|
@ -132,6 +132,7 @@ let
|
|||
rev = "91c70c6ec62e407bd6d0233fbc2c64bafc3b6cdc";
|
||||
fetchSubmodules = true;
|
||||
};
|
||||
configureFlags = [ "-fdebug" ];
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
libraryHaskellDepends = [
|
||||
|
|
|
|||
|
|
@ -43,9 +43,9 @@ traverseGraph imat acc (GHall sub) =
|
|||
foldl (traverseGraph imat) acc sub
|
||||
traverseGraph imat (rng, putt) (GRoom _ bnds) =
|
||||
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
|
||||
(\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])
|
||||
roomType = fst (L.minimumBy
|
||||
(\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)
|
||||
mat
|
||||
) :: Int
|
||||
cmat = clusterMat appl dim g2_2
|
||||
(cmat, nrp) = clusterMatWithRPs appl dim g2_2
|
||||
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 dim))
|
||||
reachdirs = map pointDir (clusterPoints appl dim)
|
||||
reachtypes = map pointType (clusterPoints appl dim)
|
||||
oldreaches = foldl (\acc p ->
|
||||
if pointType p /= RoomExit && inBounds (pointCoord p) bnds
|
||||
then pointCoord p : acc
|
||||
|
|
@ -106,16 +102,20 @@ placeCluster imat rng bnds dim try mat rp appl =
|
|||
)
|
||||
[]
|
||||
rp
|
||||
reaches = (map (+ V2 (pr - 1) (pc - 1)) (map pointCoord nrp))
|
||||
newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c)
|
||||
(zip3 reachtypes reaches reachdirs)
|
||||
(zip3
|
||||
(map pointType nrp)
|
||||
reaches
|
||||
(map pointDir nrp)
|
||||
)
|
||||
in
|
||||
if try >= 10 || fromIntegral freeRoom <= size (appl, dim)
|
||||
if try >= 10 || fromIntegral freeRoom <= size (appl, dim, g2)
|
||||
then (g2, (mat, rp))
|
||||
else
|
||||
if pr + nrows cmat - 1 > fst (matmax bnds) ||
|
||||
pc + ncols cmat - 1 > snd (matmax bnds)
|
||||
then A.log A.Debug ("no cluster placed") $
|
||||
placeCluster imat g2 bnds dim (try + 1) mat rp appl
|
||||
then placeCluster imat g2 bnds dim (try + 1) mat rp appl
|
||||
else if
|
||||
any (`notElem` clusterRoom appl)
|
||||
(M.toList (M.submatrix
|
||||
|
|
@ -129,21 +129,17 @@ placeCluster imat rng bnds dim try mat rp appl =
|
|||
pc (pc + ncols cmat - 1)
|
||||
mat
|
||||
))
|
||||
then A.log A.Debug ("no cluster placed") $
|
||||
placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
|
||||
then placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
|
||||
else if
|
||||
any (`elem` (oldreaches))
|
||||
(V2
|
||||
<$> [pr .. pr + nrows cmat - 1]
|
||||
<*> [pc .. pc + ncols cmat - 1])
|
||||
then A.log A.Debug ("no cluster placed") $
|
||||
placeCluster imat g2 bnds dim (try + 1) mat rp appl
|
||||
then placeCluster imat g2 bnds dim (try + 1) mat rp appl
|
||||
else if
|
||||
isReachable newmat [(V2 10 10, Boundaries (0, 1) (0, 1))] (oldreaches ++ reaches) exits
|
||||
then A.log A.Debug ("placed cluster" ++ show appl) $
|
||||
placeCluster imat g2_1 bnds dim (try + 1) newmat newrp appl
|
||||
else A.log A.Debug ("no cluster placed") $
|
||||
placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
|
||||
then placeCluster imat g2_1 bnds dim (try + 1) newmat newrp appl
|
||||
else placeCluster imat g2_1 bnds dim (try + 1) mat rp appl
|
||||
|
||||
insertMat
|
||||
:: Matrix (Maybe a)
|
||||
|
|
|
|||
|
|
@ -272,7 +272,7 @@ loadFork ws win glc nvg future progress = do
|
|||
, mmiscFlipchart
|
||||
, mmiscPlant1, mmiscPlant2
|
||||
, mmiscWatercooler, mmiscVending
|
||||
, mcabCoffeeSW, mcabCoffeSE
|
||||
, mcabCoffeeSW, mcabCoffeeSE
|
||||
, mcabSinkSW, mcabSinkSE
|
||||
, mcabStoveSW, mcabStoveSE
|
||||
, mcabinetSW, mcabinetSE, mcabinetCorner
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ loadMapFork ud ad future progress = do
|
|||
( p + increment
|
||||
, "Placing furniture"
|
||||
)))
|
||||
(inter, rawrps) <- placeInteriorIO mat imgmat exits gr
|
||||
(!inter, !rawrps) <- placeInteriorIO mat imgmat exits gr
|
||||
let !rps = ReachPoint Elevator (fcElevator fc) SE : rawrps
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
|
|
|
|||
|
|
@ -1,10 +1,14 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Types.Interior where
|
||||
|
||||
import qualified Affection as A
|
||||
|
||||
import Data.Matrix as M
|
||||
|
||||
import Linear.V2
|
||||
|
||||
import System.Random (StdGen, randomR)
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types.Map
|
||||
|
|
@ -12,6 +16,7 @@ import Types.ReachPoint
|
|||
import Types.ImgId
|
||||
import Types.Direction
|
||||
|
||||
|
||||
data Cluster
|
||||
= ClusterBox1
|
||||
| ClusterTableSW
|
||||
|
|
@ -28,101 +33,185 @@ data Cluster
|
|||
| ClusterToilet
|
||||
| ClusterWatercooler
|
||||
| ClusterVending
|
||||
| ClusterCabCoffee
|
||||
| ClusterCabinets
|
||||
deriving (Enum, Bounded, Show)
|
||||
|
||||
-- row -> NS; col -> WE
|
||||
clusterMat :: Cluster -> (Int, Int) -> Matrix (Maybe ImgId)
|
||||
clusterMat ClusterBox1 _ =
|
||||
M.fromLists
|
||||
[ [Just ImgMiscBox1]
|
||||
]
|
||||
clusterMat ClusterTableSW (h, _) =
|
||||
M.fromLists $ replicate h
|
||||
[Just ImgEmpty, Just ImgTableSW]
|
||||
clusterMat ClusterTableSE (_, w) =
|
||||
M.fromLists $
|
||||
[ replicate w (Just ImgTableSE)
|
||||
, replicate w (Just ImgEmpty)
|
||||
]
|
||||
clusterMat ClusterTableNE (h, _) =
|
||||
M.fromLists $ replicate h
|
||||
[Just ImgTableNE, Just ImgEmpty]
|
||||
clusterMat ClusterTableNW (_, w) =
|
||||
M.fromLists $
|
||||
[ replicate w (Just ImgEmpty)
|
||||
, replicate w (Just ImgTableNW)
|
||||
]
|
||||
clusterMat ClusterCornerTable _ =
|
||||
M.fromLists
|
||||
[ [Just ImgTableSE, Just ImgTableCorner]
|
||||
, [Just ImgEmpty, Just ImgTableSW]
|
||||
]
|
||||
clusterMat ClusterTableGroup _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
|
||||
, Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
|
||||
]
|
||||
, [ Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
|
||||
, Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
|
||||
]
|
||||
, [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
|
||||
, Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
|
||||
]
|
||||
, [ Nothing, Nothing, Nothing
|
||||
, Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
|
||||
]
|
||||
, [ Nothing, Nothing, Nothing
|
||||
, Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
|
||||
]
|
||||
]
|
||||
clusterMat ClusterCopier _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgEmptyNoWalk]
|
||||
, [ Just ImgEmpty]
|
||||
]
|
||||
clusterMat ClusterFlipchart _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgMiscFlipchart]
|
||||
, [ Just ImgEmpty]
|
||||
]
|
||||
clusterMat ClusterConferenceTable (h, w) =
|
||||
clusterMatWithRPs :: Cluster -> (Int, Int) -> StdGen -> (Matrix (Maybe ImgId), [ReachPoint])
|
||||
clusterMatWithRPs ClusterBox1 dim _ =
|
||||
( M.fromLists
|
||||
[ [Just ImgMiscBox1]
|
||||
]
|
||||
, clusterPoints ClusterBox1 dim
|
||||
)
|
||||
clusterMatWithRPs ClusterTableSW dim@(h, _) _ =
|
||||
( M.fromLists $ replicate h
|
||||
[Just ImgEmpty, Just ImgTableSW]
|
||||
, clusterPoints ClusterTableSW dim
|
||||
)
|
||||
clusterMatWithRPs ClusterTableSE dim@(_, w) _ =
|
||||
( M.fromLists $
|
||||
[ replicate w (Just ImgTableSE)
|
||||
, replicate w (Just ImgEmpty)
|
||||
]
|
||||
, clusterPoints ClusterTableSE dim
|
||||
)
|
||||
clusterMatWithRPs ClusterTableNE dim@(h, _) _ =
|
||||
( M.fromLists $ replicate h
|
||||
[Just ImgTableNE, Just ImgEmpty]
|
||||
, clusterPoints ClusterTableNE dim
|
||||
)
|
||||
clusterMatWithRPs ClusterTableNW dim@(_, w) _ =
|
||||
( M.fromLists $
|
||||
[ replicate w (Just ImgEmpty)
|
||||
, replicate w (Just ImgTableNW)
|
||||
]
|
||||
, clusterPoints ClusterTableNW dim
|
||||
)
|
||||
clusterMatWithRPs ClusterCornerTable dim _ =
|
||||
( M.fromLists
|
||||
[ [Just ImgTableSE, Just ImgTableCorner]
|
||||
, [Just ImgEmpty, Just ImgTableSW]
|
||||
]
|
||||
, clusterPoints ClusterCornerTable dim
|
||||
)
|
||||
clusterMatWithRPs ClusterTableGroup dim _ =
|
||||
( M.fromLists
|
||||
[ [ Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
|
||||
, Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
|
||||
]
|
||||
, [ Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
|
||||
, Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
|
||||
]
|
||||
, [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
|
||||
, Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
|
||||
]
|
||||
, [ Nothing, Nothing, Nothing
|
||||
, Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
|
||||
]
|
||||
, [ Nothing, Nothing, Nothing
|
||||
, Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
|
||||
]
|
||||
]
|
||||
, 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
|
||||
mh = max 4 h
|
||||
in M.fromLists $
|
||||
[ replicate mw (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 ]) ++
|
||||
[ [ Just ImgEmpty, Just ImgTableC1] ++ replicate (mw-4) (Just ImgTableSE) ++
|
||||
[ Just ImgTableC2, Just ImgEmpty ]
|
||||
, replicate mw (Just ImgEmpty)
|
||||
]
|
||||
clusterMat ClusterPlant1 _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgMiscPlant1 ] ]
|
||||
clusterMat ClusterPlant2 _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgMiscPlant2 ] ]
|
||||
clusterMat ClusterToilet _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgEmpty, Just ImgEmptyNoWalk] ]
|
||||
clusterMat ClusterWatercooler _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgMiscWatercooler ]
|
||||
, [ Just ImgEmpty ]
|
||||
]
|
||||
clusterMat ClusterVending _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgMiscVending ]
|
||||
, [ Just ImgEmpty ]
|
||||
]
|
||||
clusterMat ClusterCabCoffee _ =
|
||||
M.fromLists
|
||||
[ [ Just ImgEmpty, Just ImgCabinetCoffee ]
|
||||
]
|
||||
in
|
||||
( M.fromLists $
|
||||
[ replicate mw (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 ]) ++
|
||||
[ [ Just ImgEmpty, Just ImgTableC1] ++ replicate (mw-4) (Just ImgTableSE) ++
|
||||
[ Just ImgTableC2, Just ImgEmpty ]
|
||||
, replicate mw (Just ImgEmpty)
|
||||
]
|
||||
, clusterPoints ClusterConferenceTable dim
|
||||
)
|
||||
clusterMatWithRPs ClusterPlant1 dim _ =
|
||||
( M.fromLists
|
||||
[ [ Just ImgMiscPlant1 ] ]
|
||||
, clusterPoints ClusterPlant1 dim
|
||||
)
|
||||
clusterMatWithRPs ClusterPlant2 dim _ =
|
||||
( M.fromLists
|
||||
[ [ Just ImgMiscPlant2 ] ]
|
||||
, clusterPoints ClusterPlant2 dim
|
||||
)
|
||||
clusterMatWithRPs ClusterToilet dim _ =
|
||||
( M.fromLists
|
||||
[ [ Just ImgEmpty, Just ImgEmptyNoWalk] ]
|
||||
, clusterPoints ClusterToilet dim
|
||||
)
|
||||
clusterMatWithRPs ClusterWatercooler dim _ =
|
||||
( M.fromLists
|
||||
[ [ Just ImgMiscWatercooler ]
|
||||
, [ 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 ClusterBox1 = [Offi]
|
||||
|
|
@ -140,7 +229,7 @@ clusterRoom ClusterPlant2 = [Offi]
|
|||
clusterRoom ClusterToilet = [Toil]
|
||||
clusterRoom ClusterWatercooler = [Kitc, Offi]
|
||||
clusterRoom ClusterVending = [Kitc]
|
||||
clusterRoom ClusterCabCoffee = [Kitc]
|
||||
clusterRoom ClusterCabinets = [Kitc]
|
||||
|
||||
clusterPoints :: Cluster -> (Int, Int) -> [ReachPoint]
|
||||
clusterPoints ClusterBox1 _ = []
|
||||
|
|
@ -183,12 +272,9 @@ clusterPoints ClusterWatercooler _ =
|
|||
clusterPoints ClusterVending _ =
|
||||
[ ReachPoint Eat (V2 2 1) NW
|
||||
]
|
||||
clusterPoints ClusterCabCoffee _ =
|
||||
[ ReachPoint Drink (V2 1 1) NE
|
||||
]
|
||||
clusterPoints _ _ = []
|
||||
|
||||
instance Size (Cluster, (Int, Int)) where
|
||||
size (c, dim) =
|
||||
let mat = clusterMat c dim
|
||||
instance Size (Cluster, (Int, Int), StdGen) where
|
||||
size (c, dim, gen) =
|
||||
let mat = fst $ clusterMatWithRPs c dim gen
|
||||
in fromIntegral ((nrows mat) * (ncols mat))
|
||||
|
|
|
|||
Loading…
Reference in a new issue