diff --git a/shell.nix b/shell.nix index 1db47b4..6fb1dfd 100644 --- a/shell.nix +++ b/shell.nix @@ -132,6 +132,7 @@ let rev = "91c70c6ec62e407bd6d0233fbc2c64bafc3b6cdc"; fetchSubmodules = true; }; + configureFlags = [ "-fdebug" ]; isLibrary = true; isExecutable = true; libraryHaskellDepends = [ diff --git a/src/Interior.hs b/src/Interior.hs index fe4ba82..1c37f6a 100644 --- a/src/Interior.hs +++ b/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") $ - 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) diff --git a/src/Load.hs b/src/Load.hs index da769da..7ebd169 100644 --- a/src/Load.hs +++ b/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 diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 1596dca..edd9b16 100644 --- a/src/MainGame/WorldMap.hs +++ b/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 diff --git a/src/Types/Interior.hs b/src/Types/Interior.hs index 16eed2a..a5e83ff 100644 --- a/src/Types/Interior.hs +++ b/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) -clusterMat ClusterBox1 _ = - M.fromLists - [ [Just ImgMiscBox1] - ] -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 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 _ = - M.fromLists - [ [Just ImgTableSE, Just ImgTableCorner] - , [Just ImgEmpty, Just ImgTableSW] - ] -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 _ = - M.fromLists - [ [ Just ImgMiscFlipchart] - , [ Just ImgEmpty] - ] -clusterMat ClusterConferenceTable (h, w) = +clusterMatWithRPs :: Cluster -> (Int, Int) -> StdGen -> (Matrix (Maybe ImgId), [ReachPoint]) +clusterMatWithRPs ClusterBox1 dim _ = + ( M.fromLists + [ [Just ImgMiscBox1] + ] + , clusterPoints ClusterBox1 dim + ) +clusterMatWithRPs ClusterTableSW dim@(h, _) _ = + ( M.fromLists $ replicate h + [Just ImgEmpty, Just ImgTableSW] + , clusterPoints ClusterTableSW dim + ) +clusterMatWithRPs ClusterTableSE dim@(_, w) _ = + ( M.fromLists $ + [ replicate w (Just ImgTableSE) + , replicate w (Just ImgEmpty) + ] + , clusterPoints ClusterTableSE dim + ) +clusterMatWithRPs ClusterTableNE dim@(h, _) _ = + ( M.fromLists $ replicate h + [Just ImgTableNE, Just ImgEmpty] + , clusterPoints ClusterTableNE dim + ) +clusterMatWithRPs ClusterTableNW dim@(_, w) _ = + ( M.fromLists $ + [ replicate w (Just ImgEmpty) + , replicate w (Just ImgTableNW) + ] + , clusterPoints ClusterTableNW dim + ) +clusterMatWithRPs ClusterCornerTable dim _ = + ( M.fromLists + [ [Just ImgTableSE, Just ImgTableCorner] + , [Just ImgEmpty, Just ImgTableSW] + ] + , clusterPoints ClusterCornerTable dim + ) +clusterMatWithRPs ClusterTableGroup dim _ = + ( 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 + ] + ] + , 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 $ - [ replicate mw (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 ]) ++ - [ [ Just ImgEmpty, Just ImgTableC1] ++ replicate (mw-4) (Just ImgTableSE) ++ - [ Just ImgTableC2, Just ImgEmpty ] - , replicate mw (Just ImgEmpty) - ] -clusterMat ClusterPlant1 _ = - M.fromLists - [ [ Just ImgMiscPlant1 ] ] -clusterMat ClusterPlant2 _ = - M.fromLists - [ [ Just ImgMiscPlant2 ] ] -clusterMat ClusterToilet _ = - M.fromLists - [ [ Just ImgEmpty, Just ImgEmptyNoWalk] ] -clusterMat ClusterWatercooler _ = - M.fromLists - [ [ Just ImgMiscWatercooler ] - , [ Just ImgEmpty ] - ] -clusterMat ClusterVending _ = - M.fromLists - [ [ Just ImgMiscVending ] - , [ Just ImgEmpty ] - ] -clusterMat ClusterCabCoffee _ = - M.fromLists - [ [ Just ImgEmpty, Just ImgCabinetCoffee ] - ] + in + ( M.fromLists $ + [ replicate mw (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 ]) ++ + [ [ Just ImgEmpty, Just ImgTableC1] ++ replicate (mw-4) (Just ImgTableSE) ++ + [ Just ImgTableC2, Just ImgEmpty ] + , replicate mw (Just ImgEmpty) + ] + , clusterPoints ClusterConferenceTable dim + ) +clusterMatWithRPs ClusterPlant1 dim _ = + ( M.fromLists + [ [ Just ImgMiscPlant1 ] ] + , clusterPoints ClusterPlant1 dim + ) +clusterMatWithRPs ClusterPlant2 dim _ = + ( M.fromLists + [ [ Just ImgMiscPlant2 ] ] + , clusterPoints ClusterPlant2 dim + ) +clusterMatWithRPs ClusterToilet dim _ = + ( M.fromLists + [ [ Just ImgEmpty, Just ImgEmptyNoWalk] ] + , clusterPoints ClusterToilet dim + ) +clusterMatWithRPs ClusterWatercooler dim _ = + ( M.fromLists + [ [ Just ImgMiscWatercooler ] + , [ 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 - 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))