clean messy tables and create dynamic clusters

src/Interior.hs

@@ -41,11 +41,11 @@ traverseGraph
   -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
 traverseGraph imat acc (GHall sub) =
   foldl (traverseGraph imat) acc sub
-traverseGraph imat putt (GRoom _ bnds) =
+traverseGraph imat (rng, putt) (GRoom _ bnds) =
   let applicable =
-        L.sortBy (\b a -> size a `compare` size b) (
+        L.sortBy (\b a -> size (a, (ph, pw)) `compare` size (b, (ph, pw))) (
           L.filter
-            (\a -> roomType `elem` clusterRoom a && size a <= size bnds)
+            (\a -> roomType `elem` clusterRoom a && size (a, (ph, pw)) <= size bnds)
             [minBound .. maxBound] :: [Cluster])
       roomType = fst (L.minimumBy
         (\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
@@ -60,22 +60,25 @@ traverseGraph imat putt (GRoom _ bnds) =
             imat
             )
         )
+      (ph, g1) = randomR (1, fst (matmax bnds) - fst (matmin bnds) + 1) rng
+      (pw, g2) = randomR (1, snd (matmax bnds) - snd (matmin bnds) + 1) g1
   in
     foldl
-      (\(orng, (omat, orp)) -> placeCluster imat orng bnds 1 omat orp)
-      putt
+      (\(orng, (omat, orp)) -> placeCluster imat orng bnds (ph, pw) 1 omat orp)
+      (g2, putt)
       applicable
 
 placeCluster
   :: Matrix TileState
   -> StdGen
   -> Boundaries Int
+  -> (Int, Int)
   -> Int
   -> Matrix (Maybe ImgId)
   -> [ReachPoint]
   -> Cluster
   -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
-placeCluster imat rng bnds try mat rp appl =
+placeCluster imat rng bnds dim try mat rp appl =
   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
       freeRoom = foldl
@@ -86,15 +89,15 @@ placeCluster imat rng bnds try mat rp appl =
           (snd $ matmin bnds) (snd $ matmax bnds)
           mat
           ) :: Int
-      cmat = clusterMat appl
+      cmat = clusterMat appl dim
       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))
-      reachdirs = map pointDir (clusterPoints appl)
-      reachtypes = map pointType (clusterPoints appl)
+        (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
@@ -105,13 +108,13 @@ placeCluster imat rng bnds try mat rp appl =
       newrp = rp ++ map (\(a, b, c) -> ReachPoint a b c)
         (zip3 reachtypes reaches reachdirs)
   in
-    if try >= 10 || fromIntegral freeRoom <= size appl
+    if try >= 10 || fromIntegral freeRoom <= size (appl, dim)
     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 (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
@@ -126,20 +129,20 @@ placeCluster imat rng bnds try mat rp appl =
             mat
             ))
         then A.log A.Debug ("no cluster placed") $
-          placeCluster imat g2 bnds (try + 1) mat rp appl
+          placeCluster imat g2 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 (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) $
-              placeCluster imat g2 bnds (try + 1) newmat newrp appl
+              placeCluster imat g2 bnds dim (try + 1) newmat newrp appl
             else A.log A.Debug ("no cluster placed") $
-              placeCluster imat g2 bnds (try + 1) mat rp appl
+              placeCluster imat g2 bnds dim (try + 1) mat rp appl
 
 insertMat
   :: Matrix (Maybe a)

src/Load.hs

@@ -143,24 +143,24 @@ loadFork ws win glc nvg future progress = do
   mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
-    , "Loading asset \"table1\""
+    , "Loading asset \"tableSW\""
     )))
-  mtable1 <- createImage nvg (FileName "assets/table/table1.png") 0
+  mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
-    , "Loading asset \"table2\""
+    , "Loading asset \"tableSE\""
     )))
-  mtable2 <- createImage nvg (FileName "assets/table/table2.png") 0
+  mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
-    , "Loading asset \"table3\""
+    , "Loading asset \"tableNE\""
     )))
-  mtable3 <- createImage nvg (FileName "assets/table/table3.png") 0
+  mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
-    , "Loading asset \"table4\""
+    , "Loading asset \"tableNW\""
     )))
-  mtable4 <- createImage nvg (FileName "assets/table/table4.png") 0
+  mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableC1\""
@@ -217,7 +217,7 @@ loadFork ws win glc nvg future progress = do
         , mwallcornern, mwallcornere, mwallcorners, mwallcornerw
         , mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross
         , mmiscbox1
-        , mtable1, mtable2, mtable3, mtable4, mtableC
+        , mtableSW, mtableNW, mtableNE, mtableSE, mtableC
         , mtablec1, mtablec2, mtablec3, mtablec4
         , mmiscFlipchart
         , mmiscPlant1, mmiscPlant2

src/MainGame/WorldMap.hs

@@ -106,7 +106,7 @@ loadMapFork ud ad future progress = do
       fc = FloorConfig
         (V2 10 10)
         [(V2 5 5), (V2 5 20)]
-        (40, 40)
+        (50, 50)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Building floor"

src/Types/Collidible.hs

@@ -56,16 +56,16 @@ instance Collidible ImgId where
     [ Boundaries (0.34, 0) (0.66, 1)
     , Boundaries (0, 0.34) (1, 0.66)
     ]
-  collisionObstacle ImgTable1 =
+  collisionObstacle ImgTableSW =
     [ Boundaries (0, 0.34) (1, 1)
     ]
-  collisionObstacle ImgTable2 =
+  collisionObstacle ImgTableNW =
     [ Boundaries (0, 0) (0.63, 1)
     ]
-  collisionObstacle ImgTable3 =
+  collisionObstacle ImgTableNE =
     [ Boundaries (0, 0) (1, 0.63)
     ]
-  collisionObstacle ImgTable4 =
+  collisionObstacle ImgTableSE =
     [ Boundaries (0.34, 0) (1, 1)
     ]
   collisionObstacle ImgTableCorner =

src/Types/ImgId.hs

@@ -21,10 +21,10 @@ data ImgId
   | ImgWallTNW
   | ImgWallCross
   | ImgMiscBox1
-  | ImgTable1
-  | ImgTable2
-  | ImgTable3
-  | ImgTable4
+  | ImgTableSW
+  | ImgTableNW
+  | ImgTableNE
+  | ImgTableSE
   | ImgTableCorner
   | ImgTableC1
   | ImgTableC2

src/Types/Interior.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 module Types.Interior where
 
 import Data.Matrix as M
@@ -13,127 +14,98 @@ import Types.Direction
 
 data Cluster
   = ClusterBox1
-  | ClusterTable1
-  | ClusterTable2
-  | ClusterTable3
-  | ClusterTable4
+  | ClusterTableSW
+  | ClusterTableNW
+  | ClusterTableNE
+  | ClusterTableSE
   | ClusterCornerTable
   | ClusterTableGroup
   | ClusterCopier
   | ClusterFlipchart
-  | ClusterConferenceTable1
-  | ClusterConferenceTable2
+  | ClusterConferenceTable
   | ClusterPlant1
   | ClusterPlant2
   | ClusterToilet
   | ClusterWatercooler
   deriving (Enum, Bounded, Show)
 
-clusterMat :: Cluster -> Matrix (Maybe ImgId)
-clusterMat ClusterBox1 =
+-- row -> NS; col -> WE
+clusterMat :: Cluster -> (Int, Int) -> Matrix (Maybe ImgId)
+clusterMat ClusterBox1 _ =
   M.fromLists
-    -- [ [         Nothing]
     [ [Just ImgMiscBox1]
-    -- , [Nothing,          Nothing, Nothing]
     ]
-clusterMat ClusterTable1 =
-  M.fromLists
-    [[Just ImgEmpty, Just ImgTable1]]
-clusterMat ClusterTable2 =
-  M.fromLists
-    [ [Just ImgTable2]
-    , [Just ImgEmpty]
+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 ClusterTable3 =
-  M.fromLists
-    [[Just ImgTable3, Just ImgEmpty]]
-clusterMat ClusterTable4 =
-  M.fromLists
-    [ [Just ImgEmpty]
-    , [Just ImgTable4]
+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 =
+clusterMat ClusterCornerTable _ =
   M.fromLists
-    [ [Just ImgTable2, Just ImgTableCorner]
-    , [Just ImgEmpty, Just ImgTable1]
+    [ [Just ImgTableSE, Just ImgTableCorner]
+    , [Just ImgEmpty,   Just ImgTableSW]
     ]
-clusterMat ClusterTableGroup =
-  M.fromLists
-    [ [ Just ImgEmpty, Just ImgTable2, Just ImgTableCorner
-      , Just ImgEmpty, Just ImgTable2, Just ImgTableCorner
-      ]
-    , [ Just ImgEmpty, Just ImgEmpty, Just ImgTable1
-      , Just ImgEmpty, Just ImgEmpty, Just ImgTable1
-      ]
-    , [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      , Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      ]
-    , [ Nothing, Nothing, Nothing
-      , Just ImgEmpty, Just ImgTable2, Just ImgTableCorner
-      ]
-    , [ Nothing, Nothing, Nothing
-      , Just ImgEmpty, Just ImgEmpty, Just ImgTable1
-      ]
-    ]
-clusterMat ClusterCopier =
+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 =
+clusterMat ClusterFlipchart _ =
   M.fromLists
     [ [ Just ImgMiscFlipchart]
     , [ Just ImgEmpty]
     ]
-clusterMat ClusterConferenceTable1 =
-  M.fromLists
-    [ [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      , Just ImgEmpty, Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgTableC4, Just ImgTable4, Just ImgTable4
-      , Just ImgTable4, Just ImgTable4, Just ImgTableC3, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgTable1, Just ImgEmpty, Just ImgEmpty
-      , Just ImgEmpty, Just ImgEmpty, Just ImgTable3, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgTable1, Just ImgEmpty, Just ImgEmpty
-      , Just ImgEmpty, Just ImgEmpty, Just ImgTable3, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgTableC1, Just ImgTable2, Just ImgTable2
-      , Just ImgTable2, Just ImgTable2, Just ImgTableC2, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      , Just ImgEmpty, Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      ]
+clusterMat ClusterConferenceTable (h, w) =
+  M.fromLists $
+    [ replicate w (Just ImgEmpty)
+    , [ Just ImgEmpty, Just ImgTableC4] ++ replicate (w-4) (Just ImgTableNW) ++
+      [ Just ImgTableC3, Just ImgEmpty ]
+    ] ++
+    replicate (h-4) ([ Just ImgEmpty, Just ImgTableSW] ++ replicate (w-4) (Just ImgEmpty) ++
+      [ Just ImgTableNE, Just ImgEmpty ]) ++
+    [ [ Just ImgEmpty, Just ImgTableC1] ++ replicate (w-4) (Just ImgTableSE) ++
+      [ Just ImgTableC2, Just ImgEmpty ]
+    , replicate w (Just ImgEmpty)
     ]
-clusterMat ClusterConferenceTable2 =
-  M.fromLists
-    [ [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      , Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgTableC4, Just ImgTable4
-      , Just ImgTable4, Just ImgTableC3, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgTable1, Just ImgEmpty
-      , Just ImgEmpty, Just ImgTable3, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgTableC1, Just ImgTable2
-      , Just ImgTable2, Just ImgTableC2, Just ImgEmpty
-      ]
-    , [ Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      , Just ImgEmpty, Just ImgEmpty, Just ImgEmpty
-      ]
-    ]
-clusterMat ClusterPlant1 =
+clusterMat ClusterPlant1 _ =
   M.fromLists
     [ [ Just ImgMiscPlant1 ] ]
-clusterMat ClusterPlant2 =
+clusterMat ClusterPlant2 _ =
   M.fromLists
     [ [ Just ImgMiscPlant2 ] ]
-clusterMat ClusterToilet =
+clusterMat ClusterToilet _ =
   M.fromLists
     [ [ Just ImgEmpty, Just ImgEmptyNoWalk] ]
-clusterMat ClusterWatercooler =
+clusterMat ClusterWatercooler _ =
   M.fromLists
     [ [ Just ImgMiscWatercooler ]
     , [ Just ImgEmpty ]
@@ -141,76 +113,58 @@ clusterMat ClusterWatercooler =
 
 clusterRoom :: Cluster -> [TileState]
 clusterRoom ClusterBox1             = [Offi]
-clusterRoom ClusterTable1           = [Offi]
-clusterRoom ClusterTable2           = [Offi]
-clusterRoom ClusterTable3           = [Offi]
-clusterRoom ClusterTable4           = [Offi]
+clusterRoom ClusterTableSW          = [Offi]
+clusterRoom ClusterTableNW          = [Offi]
+clusterRoom ClusterTableNE          = [Offi]
+clusterRoom ClusterTableSE          = [Offi]
 clusterRoom ClusterCornerTable      = [Offi]
 clusterRoom ClusterTableGroup       = [Offi]
 clusterRoom ClusterCopier           = [Offi]
 clusterRoom ClusterFlipchart        = [Offi]
-clusterRoom ClusterConferenceTable1 = [Offi]
-clusterRoom ClusterConferenceTable2 = [Offi]
+clusterRoom ClusterConferenceTable  = [Offi]
 clusterRoom ClusterPlant1           = [Offi]
 clusterRoom ClusterPlant2           = [Offi]
 clusterRoom ClusterToilet           = [Toil]
 clusterRoom ClusterWatercooler      = [Kitc, Offi]
 
-clusterPoints :: Cluster -> [ReachPoint]
-clusterPoints ClusterBox1 = []
-clusterPoints ClusterTable1 =
-  [ ReachPoint Table (V2 1 1) NE]
-clusterPoints ClusterTable2 =
-  [ ReachPoint Table (V2 2 1) NW]
-clusterPoints ClusterTable3 =
-  [ ReachPoint Table (V2 1 2) SW]
-clusterPoints ClusterTable4 =
-  [ ReachPoint Table (V2 1 1) SE]
-clusterPoints ClusterCornerTable =
+clusterPoints :: Cluster -> (Int, Int) -> [ReachPoint]
+clusterPoints ClusterBox1 _ = []
+clusterPoints ClusterTableNE (h, _) =
+  [ ReachPoint Table (V2 r 2) SW | r <- [1..h] ]
+clusterPoints ClusterTableNW (_, w) =
+  [ ReachPoint Table (V2 1 c) SE | c <- [1..w] ]
+clusterPoints ClusterTableSW (h, _) =
+  [ ReachPoint Table (V2 r 1) NE | r <- [1..h] ]
+clusterPoints ClusterTableSE (_, w) =
+  [ ReachPoint Table (V2 2 c) NW | c <- [1..w] ]
+clusterPoints ClusterCornerTable _ =
   [ ReachPoint Computer (V2 2 1) N
   ]
-clusterPoints ClusterTableGroup =
+clusterPoints ClusterTableGroup _ =
   [ ReachPoint Computer (V2 2 2) N
   , ReachPoint Computer (V2 2 5) N
   , ReachPoint Computer (V2 5 5) N
   ]
-clusterPoints ClusterCopier =
+clusterPoints ClusterCopier _ =
   [ ReachPoint Copier (V2 2 1) NW
   ]
-clusterPoints ClusterFlipchart =
+clusterPoints ClusterFlipchart _ =
   [ ReachPoint Table (V2 2 1) NW
   ]
-clusterPoints ClusterConferenceTable1 =
-  [ ReachPoint Table (V2 1 3) SE
-  , ReachPoint Table (V2 1 4) SE
-  , ReachPoint Table (V2 1 5) SE
-  , ReachPoint Table (V2 1 6) SE
-  , ReachPoint Table (V2 3 1) NE
-  , ReachPoint Table (V2 3 8) SW
-  , ReachPoint Table (V2 4 1) NE
-  , ReachPoint Table (V2 4 8) SW
-  , ReachPoint Table (V2 6 3) NW
-  , ReachPoint Table (V2 6 4) NW
-  , ReachPoint Table (V2 6 5) NW
-  , ReachPoint Table (V2 6 6) NW
-  ]
-clusterPoints ClusterConferenceTable2 =
-  [ ReachPoint Table (V2 1 3) SE
-  , ReachPoint Table (V2 1 4) SE
-  , ReachPoint Table (V2 3 1) NE
-  , ReachPoint Table (V2 3 6) SW
-  , ReachPoint Table (V2 5 3) NW
-  , ReachPoint Table (V2 5 4) NW
-  ]
-clusterPoints ClusterToilet =
+clusterPoints ClusterConferenceTable (h, w) =
+  [ ReachPoint Table (V2 1 c) SE | c <- [2..w-2] ] ++
+  [ ReachPoint Table (V2 r 1) NE | r <- [2..h-2] ] ++
+  [ ReachPoint Table (V2 r w) SW | r <- [2..h-2] ] ++
+  [ ReachPoint Table (V2 h c) NW | c <- [2..w-2] ]
+clusterPoints ClusterToilet _ =
   [ ReachPoint Toilet (V2 1 1) NE
   ]
-clusterPoints ClusterWatercooler =
+clusterPoints ClusterWatercooler _ =
   [ ReachPoint Drink (V2 2 1) NW
   ]
-clusterPoints _ = []
+clusterPoints _ _ = []
 
-instance Size Cluster where
-  size c =
-    let mat = clusterMat c
+instance Size (Cluster, (Int, Int)) where
+  size (c, dim) =
+    let mat = clusterMat c dim
     in  fromIntegral ((nrows mat) * (ncols mat))