create kithen cabinets on map

shell.nix

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

src/Interior.hs

@@ -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") $
+      then placeCluster imat g2 bnds dim (try + 1) mat rp appl
-        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") $
+        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
           any (`elem` (oldreaches))
           (V2
             <$> [pr .. pr + nrows 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
             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
   :: Matrix (Maybe a)

src/Load.hs

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

src/MainGame/WorldMap.hs

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

src/Types/Interior.hs

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