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";
fetchSubmodules = true;
};
configureFlags = [ "-fdebug" ];
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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,38 +33,50 @@ 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
clusterMatWithRPs :: Cluster -> (Int, Int) -> StdGen -> (Matrix (Maybe ImgId), [ReachPoint])
clusterMatWithRPs ClusterBox1 dim _ =
( M.fromLists
[ [Just ImgMiscBox1]
]
clusterMat ClusterTableSW (h, _) =
M.fromLists $ replicate h
, clusterPoints ClusterBox1 dim
)
clusterMatWithRPs ClusterTableSW dim@(h, _) _ =
( M.fromLists $ replicate h
[Just ImgEmpty, Just ImgTableSW]
clusterMat ClusterTableSE (_, w) =
M.fromLists $
, clusterPoints ClusterTableSW dim
)
clusterMatWithRPs ClusterTableSE dim@(_, w) _ =
( M.fromLists $
[ replicate w (Just ImgTableSE)
, replicate w (Just ImgEmpty)
]
clusterMat ClusterTableNE (h, _) =
M.fromLists $ replicate h
, clusterPoints ClusterTableSE dim
)
clusterMatWithRPs ClusterTableNE dim@(h, _) _ =
( M.fromLists $ replicate h
[Just ImgTableNE, Just ImgEmpty]
clusterMat ClusterTableNW (_, w) =
M.fromLists $
, clusterPoints ClusterTableNE dim
)
clusterMatWithRPs ClusterTableNW dim@(_, w) _ =
( M.fromLists $
[ replicate w (Just ImgEmpty)
, replicate w (Just ImgTableNW)
]
clusterMat ClusterCornerTable _ =
M.fromLists
, clusterPoints ClusterTableNW dim
)
clusterMatWithRPs ClusterCornerTable dim _ =
( M.fromLists
[ [Just ImgTableSE, Just ImgTableCorner]
, [Just ImgEmpty, Just ImgTableSW]
]
clusterMat ClusterTableGroup _ =
M.fromLists
, clusterPoints ClusterCornerTable dim
)
clusterMatWithRPs ClusterTableGroup dim _ =
( M.fromLists
[ [ Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
, Just ImgEmpty, Just ImgTableSE, Just ImgTableCorner
]
@ -76,20 +93,27 @@ clusterMat ClusterTableGroup _ =
, Just ImgEmpty, Just ImgEmpty, Just ImgTableSW
]
]
clusterMat ClusterCopier _ =
M.fromLists
, clusterPoints ClusterTableGroup dim
)
clusterMatWithRPs ClusterCopier dim _ =
( M.fromLists
[ [ Just ImgEmptyNoWalk]
, [ Just ImgEmpty]
]
clusterMat ClusterFlipchart _ =
M.fromLists
, clusterPoints ClusterCopier dim
)
clusterMatWithRPs ClusterFlipchart dim _ =
( M.fromLists
[ [ Just ImgMiscFlipchart]
, [ Just ImgEmpty]
]
clusterMat ClusterConferenceTable (h, w) =
, clusterPoints ClusterFlipchart dim
)
clusterMatWithRPs ClusterConferenceTable dim@(h, w) _ =
let mw = max 4 w
mh = max 4 h
in M.fromLists $
in
( M.fromLists $
[ replicate mw (Just ImgEmpty)
, [ Just ImgEmpty, Just ImgTableC4] ++ replicate (mw-4) (Just ImgTableNW) ++
[ Just ImgTableC3, Just ImgEmpty ]
@ -100,29 +124,94 @@ clusterMat ClusterConferenceTable (h, w) =
[ Just ImgTableC2, Just ImgEmpty ]
, replicate mw (Just ImgEmpty)
]
clusterMat ClusterPlant1 _ =
M.fromLists
, clusterPoints ClusterConferenceTable dim
)
clusterMatWithRPs ClusterPlant1 dim _ =
( M.fromLists
[ [ Just ImgMiscPlant1 ] ]
clusterMat ClusterPlant2 _ =
M.fromLists
, clusterPoints ClusterPlant1 dim
)
clusterMatWithRPs ClusterPlant2 dim _ =
( M.fromLists
[ [ Just ImgMiscPlant2 ] ]
clusterMat ClusterToilet _ =
M.fromLists
, clusterPoints ClusterPlant2 dim
)
clusterMatWithRPs ClusterToilet dim _ =
( M.fromLists
[ [ Just ImgEmpty, Just ImgEmptyNoWalk] ]
clusterMat ClusterWatercooler _ =
M.fromLists
, clusterPoints ClusterToilet dim
)
clusterMatWithRPs ClusterWatercooler dim _ =
( M.fromLists
[ [ Just ImgMiscWatercooler ]
, [ Just ImgEmpty ]
]
clusterMat ClusterVending _ =
M.fromLists
, clusterPoints ClusterWatercooler dim
)
clusterMatWithRPs ClusterVending dim _ =
( M.fromLists
[ [ Just ImgMiscVending ]
, [ Just ImgEmpty ]
]
clusterMat ClusterCabCoffee _ =
M.fromLists
[ [ Just ImgEmpty, Just ImgCabinetCoffee ]
, 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))