placing objects

src/Floorplan.hs

@@ -12,7 +12,7 @@ import Types.Map
 
 import Debug.Trace
 
-buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
+buildHallFloorIO :: FloorConfig -> IO (Matrix TileState, [Graph])
 buildHallFloorIO fc = do
   rand <- newStdGen
   let empty         = emptyFloor fc
@@ -23,11 +23,11 @@ buildHallFloorIO fc = do
       doorgraph     = buildDoorsGraph closed
   doors <- buildDoors closed doorgraph
   let (_, facils)  = buildFacilities g2 fc doors
-  return facils
+  return (facils, doorgraph)
 
 emptyFloor :: FloorConfig -> Matrix TileState
 emptyFloor fc =
-  let (rows, cols) = size fc
+  let (rows, cols) = fcSize fc
   in  M.matrix rows cols (const Unde)
 
 buildElevator
@@ -35,7 +35,7 @@ buildElevator
   -> (StdGen, Matrix TileState)
   -> (StdGen, Matrix TileState)
 buildElevator fc (gen, empty) =
-  let (row, col) = elevator fc
+  let (row, col) = fcElevator fc
       boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x]
       buildShaft = foldl
         (\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc)
@@ -52,7 +52,7 @@ placeHalls
 placeHalls rng fc input =
   doHalls rng
    [Boundaries (1,1) (nrows input, ncols input)]
-   (elevator fc) 5 input
+   (fcElevator fc) 5 input
   where
     doHalls rand bs cross wmax mat =
       foldl (\(agen, amat) b ->
@@ -66,16 +66,16 @@ placeHalls rng fc input =
           else (g3, nmat)
         ) (rand, mat) bs
 
-boundSize :: Boundaries -> Int
+boundSize :: Boundaries Int -> Int
 boundSize (Boundaries mi ma) =
   (fst ma - fst mi) * (snd ma - snd mi)
 
 buildHall
   :: (Int, Int)
   -> Int
-  -> Boundaries
+  -> Boundaries Int
   -> Matrix TileState
-  -> ([Boundaries], Matrix TileState)
+  -> ([Boundaries Int], Matrix TileState)
 buildHall coord@(row, col) width bs mat =
   let vertHalls = foldl (flip (M.mapCol
         (\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
@@ -159,7 +159,7 @@ buildInnerWalls rng input =
               doCross
                 :: StdGen
                 -> (Int, Int)
-                -> Boundaries
+                -> Boundaries Int
                 -> Matrix TileState
                 -> (StdGen, Matrix TileState)
               doCross gen cd@(xr, xc) b imat =
@@ -256,7 +256,7 @@ buildFacilities gen fc input =
             , (cr, cc + 1)
             , (cr, cc - 1)
             ]
-      nearests = map (findNearestOffice input) (facilities fc)
+      nearests = map (findNearestOffice input) (fcFacilities fc)
   in  foldl (\(agen, acc) x ->
         let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
             facil = if numfac == 1 then Kitc else Toil

src/Init.hs

@@ -55,21 +55,23 @@ load = do
   mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
   mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
   mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
+  mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
   _ <- createFont nvg "bedstead"
     (FileName "assets/font/Bedstead-Semicondensed.ttf")
-  let mwalls = [ mwallasc, mwalldesc,
+  let mimgs = [ mwallasc, mwalldesc,
         mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
-        mwalltne, mwalltse, mwalltsw, mwalltnw,
-        mwallcross ]
-  when (any isNothing mwalls) $ do
+        mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
+        mmiscbox1
+        ]
+  when (any isNothing mimgs) $ do
     logIO Error "Failed to load walls"
     exitFailure
-  let walls = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mwalls
+  let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
   return UserData
     { state       = Menu
     , subsystems  = subs
     , assetImages = M.fromList
-      walls
+      imgs
     , assetFonts  = M.fromList
       [ (FontBedstead, "bedstead")
       ]

src/Interior.hs

@@ -0,0 +1,106 @@
+module Interior where
+
+import Affection as A
+
+import Data.Matrix as M
+import qualified Data.Map.Strict as Map
+import Data.List as L
+import Data.Maybe (isNothing, isJust)
+
+import System.Random
+
+-- internal imports
+
+import Types.Interior
+import Types.Map
+import Types.UserData
+
+placeInteriorIO :: Matrix TileState -> [Graph] -> IO (Matrix (Maybe ImgId))
+placeInteriorIO imat graph =
+  do
+    rnd <- newStdGen
+    let (_, mat) =
+          foldl
+            traverseGraph
+            (rnd, M.fromList (nrows imat) (ncols imat) (repeat Nothing))
+            graph
+    return mat
+  where
+    traverseGraph
+      :: (StdGen, Matrix (Maybe ImgId))
+      -> Graph
+      -> (StdGen, Matrix (Maybe ImgId))
+    traverseGraph acc (GHall sub) =
+      foldl traverseGraph acc sub
+    traverseGraph put@(rng, mat) (GRoom _ bnds) =
+      let applicable =
+            reverse (L.sortBy (\a b -> size a `compare` size b) (
+              L.filter
+                (\a -> clusterRoom a == roomType && size a < size bnds)
+                [minBound .. maxBound] :: [Cluster])
+              )
+          roomType = fst (head $ reverse $ L.sortBy
+            (\a b -> snd a `compare` snd b) $ Map.toList $ foldl
+              (\acc a -> if a `Map.member` acc
+                then Map.insert a (acc Map.! a + 1) acc
+                else Map.insert a 1 acc
+                )
+              Map.empty
+              (M.submatrix
+                (fst $ matmin bnds) (fst $ matmax bnds)
+                (snd $ matmin bnds) (snd $ matmax bnds)
+                imat
+                )
+            )
+      in
+        foldl (\(orng, omat) -> placeCluster orng bnds 1 omat) put applicable
+    placeCluster rng bnds try mat appl =
+      let (pr, g1) = randomR (fst (matmin bnds), fst (matmax bnds)) rng
+          (pc, g2) = randomR (snd (matmin bnds), snd (matmax bnds)) g1
+          freeRoom = foldl
+            (\acc a -> if a == Nothing then acc + 1 else acc)
+            0
+            (M.toList $ M.submatrix
+              (fst $ matmin bnds) (fst $ matmax bnds)
+              (snd $ matmin bnds) (snd $ matmax bnds)
+              mat
+              )
+          cmat = clusterMat appl
+      in
+        if try > 100 || fromIntegral freeRoom < size appl
+        then (g2, mat)
+        else
+          if pr - 1 + nrows cmat > fst (matmax bnds) ||
+             pc - 1 + ncols cmat > snd (matmax bnds) ||
+             any (/= clusterRoom appl)
+               (M.toList (M.submatrix
+                 (pr - 1) (pr + nrows cmat - 1)
+                 (pc - 1) (pc + ncols cmat - 1)
+                 imat
+                 )) ||
+             any isJust
+               (M.toList (M.submatrix
+                 (pr - 1) (pr + nrows cmat - 1)
+                 (pc - 1) (pc + ncols cmat - 1)
+                 mat
+                 ))
+          then placeCluster g2 bnds (try + 1) mat appl
+          else A.log A.Debug ("Placing stuff at: " ++ show (pr - 1, pc - 1)) (placeCluster
+            g2 bnds (try + 1) (insertMat cmat mat (pr - 1, pc - 1)) appl)
+
+insertMat
+  :: Matrix (Maybe a)
+  -> Matrix (Maybe a)
+  -> (Int, Int)
+  -> Matrix (Maybe a)
+insertMat i into (roffs, coffs) =
+  if roffs + nrows i > nrows into || coffs + ncols i > ncols into
+  then error "insertMat: matrix to be inserted does not fit!"
+  else foldl
+    (\mat (ir, ic) ->
+      if isNothing (mat M.! (ir + roffs, ic + coffs))
+      then M.setElem (i M.! (ir, ic)) (ir + roffs, ic + coffs) mat
+      else mat
+      )
+    into
+    ((,) <$> [1 .. nrows i] <*> [1 .. ncols i])

src/Test.hs

@@ -30,6 +30,7 @@ import Debug.Trace
 
 -- internal imports
 
+import Interior
 import Util
 
 loadMap :: Affection UserData ()
@@ -37,7 +38,8 @@ loadMap = do
   ud <- getAffection
   let fc = FloorConfig (20, 20) [(5,5), (35, 35)] (50,75)
       (Subsystems _ m) = subsystems ud
-  matrix <- liftIO $ buildHallFloorIO fc
+  (matrix, gr) <- liftIO $ buildHallFloorIO fc
+  inter <- liftIO $ placeInteriorIO matrix gr
   (nws, _) <- yieldSystemT (worldState ud) $ do
     void $ newEntity $ defEntity
       { pos = Just (V2 20.5 20.5)
@@ -49,7 +51,7 @@ loadMap = do
     { worldState = nws
     , stateData = MenuData
       { mapMat = matrix
-      , imgMat = convertTileToImg matrix
+      , imgMat = insertMat inter (convertTileToImg matrix) (0, 0)
       , initCoords = (0, 500)
       }
     , uuid = [uu]
@@ -124,7 +126,7 @@ drawMap = do
     fill ctx
     mapM_ (\(i, ls) -> mapM_
       (\(j, t) -> drawTile
-        ((mapMat $ stateData ud) M.! (i, j)) (assetImages ud) ctx pr pc i j t)
+        (assetImages ud) ctx pr pc i j t)
         (reverse $ zip [1..] ls))
       (zip [1..] (toLists matrix))
     fontSize ctx 20
@@ -164,8 +166,16 @@ updateMap dt = do
     { worldState = nws
     }
 
-drawTile :: TileState -> Map ImgId Image -> Context -> Double -> Double -> Int -> Int -> Maybe ImgId -> IO ()
-drawTile tile ai ctx pr pc row col img = do
+drawTile
+  :: Map ImgId Image
+  -> Context
+  -> Double
+  -> Double
+  -> Int
+  -> Int
+  -> Maybe ImgId
+  -> IO ()
+drawTile ai ctx pr pc row col img = do
   let tileWidth = 64 :: Double
       tileHeight = 32 :: Double
   save ctx
@@ -176,11 +186,13 @@ drawTile tile ai ctx pr pc row col img = do
   unless (img == Nothing) $ do
     let dist = distance (V2 (fromIntegral row) (fromIntegral col))
           (V2 (realToFrac pr - 0.5) (realToFrac pc + 0.5)) / 4
-        fact = if floor pr <= row && floor pc >= col
+        fact = if (floor pr <= row && floor pc >= col) && isWall (fromJust img)
           then min 1 dist
           else 1
     paint <- imagePattern
-      ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74 0
+      ctx x (y - (74 * fact - realToFrac tileHeight))
+      (realToFrac tileWidth) 74
+      0
       (ai Map.! fromJust img)
       fact
     beginPath ctx

src/Types.hs

@@ -4,3 +4,4 @@ module Types
 
 import Types.UserData as T
 import Types.Map as T
+import Types.Interior as T

src/Types/Interior.hs

@@ -0,0 +1,31 @@
+module Types.Interior where
+
+import Data.Matrix as M
+
+-- internal imports
+
+import Types.Map
+import Types.UserData
+
+data Cluster
+  = ClusterBox1
+  deriving (Enum, Bounded)
+
+clusterMat :: Cluster -> Matrix (Maybe ImgId)
+clusterMat ClusterBox1 =
+  M.fromLists
+    [ [Nothing,          Nothing, Nothing]
+    , [Nothing, Just ImgMiscBox1, Nothing]
+    , [Nothing,          Nothing, Nothing]
+    ]
+
+clusterRoom :: Cluster -> TileState
+clusterRoom ClusterBox1 = Offi
+
+instance Size Cluster where
+  size c =
+    let mat = clusterMat c
+    in  fromIntegral ((nrows mat) * (ncols mat))
+
+-- class ClusterData c where
+--   clusterMat :: c -> Matrix (Maybe ImgId)

src/Types/Map.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 module Types.Map where
 
 data TileState
@@ -10,7 +11,7 @@ data TileState
   | Kitc
   | Elev
   | Unde
-  deriving (Eq)
+  deriving (Ord, Eq)
 
 instance Show TileState where
   show Wall = "#"
@@ -24,16 +25,24 @@ instance Show TileState where
   show Unde = " "
 
 data FloorConfig = FloorConfig
-  { elevator    :: (Int, Int)
-  , facilities  :: [(Int, Int)]
-  , size        :: (Int, Int)
+  { fcElevator    :: (Int, Int)
+  , fcFacilities  :: [(Int, Int)]
+  , fcSize        :: (Int, Int)
   } deriving (Show)
 
-data Boundaries = Boundaries
-  { matmin :: (Int, Int)
-  , matmax :: (Int, Int)
+data Boundaries a = Boundaries
+  { matmin :: (a, a)
+  , matmax :: (a, a)
   } deriving (Show, Eq)
 
+instance Size (Boundaries Int) where
+  size (Boundaries (minr, minc) (maxr, maxc)) =
+    fromIntegral ((maxr - minr) * (maxc - minc))
+
+instance Size (Boundaries Double) where
+  size (Boundaries (minr, minc) (maxr, maxc)) =
+    (maxr - minr) * (maxc - minc)
+
 data GraphDirection = North | South | East | West
   deriving (Show, Eq)
 
@@ -43,6 +52,9 @@ data Graph
     }
   | GRoom
     { neighbs  :: [(GraphDirection, TileState)]
-    , bounds   :: Boundaries
+    , bounds   :: Boundaries Int
     }
   deriving (Show, Eq)
+
+class Size a where
+  size :: a -> Double

src/Types/UserData.hs

@@ -51,8 +51,13 @@ data ImgId
   | ImgWallTSW
   | ImgWallTNW
   | ImgWallCross
+  | ImgMiscBox1
   deriving (Show, Eq, Ord, Enum)
 
+isWall :: ImgId -> Bool
+isWall ImgMiscBox1 = False
+isWall _ = True
+
 data FontId
   = FontBedstead
   deriving (Show, Eq, Ord, Enum)
@@ -72,6 +77,7 @@ data Entity f = Entity
   , gridPos  :: Component f 'Field (V2 Int)
   , vel      :: Component f 'Field (V2 Double)
   , rot      :: Component f 'Field Direction
+  , obstacle :: Component f 'Field (Boundaries Double)
   , player   :: Component f 'Unique Bool
   }
   deriving (Generic)

tracer-game.cabal

@@ -20,8 +20,10 @@ executable tracer-game
   other-modules:       Types
                      , Types.UserData
                      , Types.Map
+                     , Types.Interior
                      , StateMachine
                      , Floorplan
+                     , Interior
                      , Init
                      , Test
                      , Util