diff --git a/assets/misc/box1.kra b/assets/misc/box1.kra new file mode 100644 index 0000000..924b37d Binary files /dev/null and b/assets/misc/box1.kra differ diff --git a/assets/misc/box1.png b/assets/misc/box1.png new file mode 100644 index 0000000..95d3648 Binary files /dev/null and b/assets/misc/box1.png differ diff --git a/src/Floorplan.hs b/src/Floorplan.hs index 5e7657e..6ac5237 100644 --- a/src/Floorplan.hs +++ b/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 diff --git a/src/Init.hs b/src/Init.hs index 2068b0e..a0e2028 100644 --- a/src/Init.hs +++ b/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") ] diff --git a/src/Interior.hs b/src/Interior.hs new file mode 100644 index 0000000..37c7a04 --- /dev/null +++ b/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]) diff --git a/src/Test.hs b/src/Test.hs index da6f392..39f7715 100644 --- a/src/Test.hs +++ b/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 diff --git a/src/Types.hs b/src/Types.hs index b39b783..f5247d5 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -4,3 +4,4 @@ module Types import Types.UserData as T import Types.Map as T +import Types.Interior as T diff --git a/src/Types/Interior.hs b/src/Types/Interior.hs new file mode 100644 index 0000000..d6b8730 --- /dev/null +++ b/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) diff --git a/src/Types/Map.hs b/src/Types/Map.hs index 8a01c4b..3dae8fd 100644 --- a/src/Types/Map.hs +++ b/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 diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 4e54fa1..add7d3d 100644 --- a/src/Types/UserData.hs +++ b/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) @@ -68,11 +73,12 @@ data Direction | SE data Entity f = Entity - { pos :: Component f 'Field (V2 Double) - , gridPos :: Component f 'Field (V2 Int) - , vel :: Component f 'Field (V2 Double) - , rot :: Component f 'Field Direction - , player :: Component f 'Unique Bool + { pos :: Component f 'Field (V2 Double) + , 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) diff --git a/tracer-game.cabal b/tracer-game.cabal index ab63021..712899b 100644 --- a/tracer-game.cabal +++ b/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