269 lines
8.8 KiB
Haskell
269 lines
8.8 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Dodge.Layout (
|
|
generateLevelFromRoomList,
|
|
tilesFromRooms,
|
|
shuffleRoomPos,
|
|
) where
|
|
|
|
import Control.Monad
|
|
-- import Dodge.Path.Translate
|
|
import qualified Control.Foldl as L
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import Data.Function
|
|
import Linear
|
|
-- import Data.Graph.Inductive (labEdges, labNodes)
|
|
import Data.List (nubBy, sortOn)
|
|
import Data.Maybe
|
|
import Data.Tile
|
|
import qualified Data.Vector.Unboxed as UV
|
|
-- import Data.Traversable
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Wall
|
|
import Dodge.GameRoom
|
|
-- import Dodge.Item.Location.Initialize
|
|
import Dodge.LevelGen.LevelStructure
|
|
import Dodge.LevelGen.StaticWalls
|
|
import Dodge.Path
|
|
import Dodge.Placement.PlaceSpot
|
|
import Dodge.Room.Link
|
|
import Dodge.ShiftPoint
|
|
import Dodge.Wall.Zone
|
|
import Dodge.Zoning.Pathing
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import RandomHelp
|
|
|
|
generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld
|
|
generateLevelFromRoomList gr' w =
|
|
over gwWorld initWallZoning
|
|
. over gwWorld randomCompass
|
|
. over gwWorld setupWorldBounds
|
|
. doInPlacements
|
|
. doIndividualPlacements
|
|
. setTiles
|
|
. worldToGenWorld rs'
|
|
$ w
|
|
& cWorld . lWorld . walls .~ wallsFromRooms rs
|
|
& cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
|
|
& cWorld . incNode .~ inodes
|
|
& cWorld . incGraph .~ igraph
|
|
& cWorld . incEdges .~ ipairs
|
|
& incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i, p) m) mempty inodes
|
|
& incEdgeZoning .~ foldl' (flip (zoneIncPe inodes)) mempty ipairs
|
|
where
|
|
pairs = snapToGrid $ foldMap _rmPath rs
|
|
(inodes, igraph, ipairs) = pairsToIncGraph pairs
|
|
rs = map doRoomShift $ IM.elems rs'
|
|
rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w
|
|
|
|
randomCompass :: World -> World
|
|
randomCompass w =
|
|
w & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
|
|
|
|
-- note the order of traversal of the rooms is important
|
|
-- hence the reverse
|
|
-- this is not ideal: should do this in some more sensible way
|
|
setTiles :: GenWorld -> GenWorld
|
|
setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
|
|
|
|
roomTileZeroShift :: Room -> Point2A
|
|
roomTileZeroShift rm = fromMaybe (rm ^. rmShift)
|
|
$ rm ^? rmFloor . tiles . ix 0 . tileZeroShift . _Just
|
|
|
|
setTile :: Room -> GenWorld -> GenWorld
|
|
setTile r gw = case _rmFloor r of
|
|
Tiled xs -> fromMaybe gw $ do
|
|
pid <- r ^. rmMParent
|
|
rm <- gw ^? genRooms . ix pid
|
|
guard $ rm ^? rmFloor . tiles . ix 0 . tileArrayZ == xs ^? ix 0 . tileArrayZ
|
|
return $ gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor . tiles . ix 0 . tileZeroShift
|
|
?~ roomTileZeroShift rm
|
|
InheritFloor ->
|
|
gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
|
|
where
|
|
t = fromMaybe (Tile poly (V2 0 0) (V2 1 0) 16 Nothing) $ do
|
|
pid <- r ^. rmMParent
|
|
rm <- gw ^? genRooms . ix pid
|
|
(rm ^? rmFloor . tiles . ix 0)
|
|
<&> tileZeroShift ?~ roomTileZeroShift rm
|
|
poly =
|
|
orderPolygon
|
|
. convexHullSafe
|
|
. nubBy ((==) `on` roundPoint2)
|
|
. concat
|
|
$ _rmPolys r
|
|
|
|
shuffleRoomPos :: (RandomGen g) => Room -> State g Room
|
|
shuffleRoomPos = rmPos shuffle
|
|
|
|
doInPlacements :: GenWorld -> GenWorld
|
|
doInPlacements w =
|
|
foldl' (\gw (i, (_, f)) -> rplaceSpot i gw (f gw)) w
|
|
. sortOn (fst . snd)
|
|
. foldMap g
|
|
$ w ^. genRooms
|
|
where
|
|
g rm = (rm ^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
|
|
rplaceSpot i gw rx = placeSpot i (gw & gwWorld . randGen .~ gen) x
|
|
where
|
|
(x,gen) = runState rx (gw ^. gwWorld . randGen)
|
|
|
|
doIndividualPlacements :: GenWorld -> GenWorld
|
|
doIndividualPlacements gw = foldl' doRoomPlacements gw (_genRooms gw)
|
|
|
|
doRoomPlacements :: GenWorld -> Room -> GenWorld
|
|
doRoomPlacements w rm =
|
|
foldl' (placeSpot i) (w & genRooms . ix i . rmPmnts .~ mempty)
|
|
. sortOn plPriority
|
|
$ _rmPmnts rm
|
|
where
|
|
i = rm ^?! rmMID . _Just
|
|
|
|
plPriority :: Placement -> Int
|
|
plPriority pl = case pl ^. plType of
|
|
PutChasm{} -> 0
|
|
PutBlock{} -> 1
|
|
PutDoor{} -> 2
|
|
_ -> 3
|
|
|
|
setupWorldBounds :: World -> World
|
|
setupWorldBounds w =
|
|
w
|
|
& cWorld . cwGen . cwgWorldBounds
|
|
%~ ( (bdMinX .~ f minx)
|
|
. (bdMaxX .~ f maxx)
|
|
. (bdMinY .~ f miny)
|
|
. (bdMaxY .~ f maxy)
|
|
)
|
|
where
|
|
f = fromMaybe 0
|
|
ps = IM.map (fst . _wlLine) $ w ^. cWorld . lWorld . walls -- _walls (_cWorld w)
|
|
(minx, maxx, miny, maxy) =
|
|
L.fold
|
|
( (,,,)
|
|
<$> L.premap fstV2 L.minimum
|
|
<*> L.premap fstV2 L.maximum
|
|
<*> L.premap sndV2 L.minimum
|
|
<*> L.premap sndV2 L.maximum
|
|
)
|
|
ps
|
|
|
|
wallsFromRooms :: [Room] -> IM.IntMap Wall
|
|
wallsFromRooms =
|
|
-- divideWalls .
|
|
IM.fromDistinctAscList
|
|
. zipWith f [0 ..]
|
|
. removeInverseWalls
|
|
. foldl' (flip cutWalls) []
|
|
. concatMap _rmPolys
|
|
where
|
|
f i (x, y) = (i, defaultWall{_wlLine = (x, y), _wlID = i})
|
|
|
|
-- TODO sort out shifting before or after etc
|
|
gameRoomsFromRooms :: [Room] -> [GameRoom]
|
|
gameRoomsFromRooms = fmap gameRoomFromRoom
|
|
|
|
gameRoomFromRoom :: Room -> GameRoom
|
|
gameRoomFromRoom rm =
|
|
GameRoom
|
|
{ _grViewpoints =
|
|
map doshift $
|
|
_rmViewpoints rm
|
|
++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
|
|
++ mapMaybe filterUnusedLinks (_rmPos rm)
|
|
, _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
|
|
, _grBound =
|
|
map doshift
|
|
$ expandPolyCorners 50
|
|
. convexHullSafe
|
|
. nubBy closePoints
|
|
. concat
|
|
$ _rmBound rm ++ _rmPolys rm
|
|
, _grRmBounds = map (map doshift) $ _rmBound rm
|
|
, _grDir = getDir $ _rmPos rm
|
|
, _grLinkDirs = mapMaybe undir $ _rmPos rm
|
|
, _grName = _rmName rm
|
|
}
|
|
where
|
|
doshift = shiftPointBy (_rmShift rm)
|
|
doubleShift p a =
|
|
map
|
|
doshift
|
|
[ p + 10 *^ unitVectorAtAngle a
|
|
, p - 10 *^ unitVectorAtAngle a
|
|
]
|
|
filterUnusedLinks rp = case _rpType rp of
|
|
UnusedLink{} -> Just $ _rpPos rp
|
|
_ -> Nothing
|
|
filterUsedLinks rp = case _rpType rp of
|
|
UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
|
|
UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
|
|
_ -> []
|
|
undir rp = case _rpType rp of
|
|
UsedOutLink{} -> ma
|
|
UsedInLink{} -> ma
|
|
_ -> Nothing
|
|
where
|
|
ma = Just $ 0.5 * pi + _rpDir rp + snd (_rmShift rm)
|
|
closePoints x y = roundPoint2 x == roundPoint2 y
|
|
getDir (rp : xs) = case _rpType rp of
|
|
UsedInLink{} -> _rpDir rp + snd (_rmShift rm)
|
|
_ -> getDir xs
|
|
getDir _ = 0 -- fallback
|
|
|
|
tilesFromRooms :: [Room] -> [Tile]
|
|
tilesFromRooms = concatMap (getTiles . _rmFloor . doRoomShift)
|
|
|
|
getTiles :: Floor -> [Tile]
|
|
getTiles fl = case fl of
|
|
Tiled xs -> xs
|
|
_ -> error "tiles not correctly set for some room"
|
|
|
|
-- divideWall :: Wall -> [Wall]
|
|
-- divideWall wl
|
|
-- = let (a,b) = _wlLine wl
|
|
-- ps = divideLine (zoneSize * 2) a b
|
|
-- in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
|
|
|
|
-- divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
|
-- divideWallIn wl wls =
|
|
-- let (wl':newWls) = divideWall wl
|
|
-- k = IM.newKey wls
|
|
-- newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
|
|
-- in foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
|
|
--
|
|
-- divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
|
-- divideWalls wls = foldl' (flip divideWallIn) wls wls
|
|
|
|
-- insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
|
|
-- insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
|
|
-- where f _ = IM.insert y obj
|
|
|
|
-- shiftRoomTree :: Tree Room -> Tree Room
|
|
-- shiftRoomTree (Node t []) = Node t []
|
|
-- shiftRoomTree (Node t ts) = Node t
|
|
-- $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
|
|
-- (_rmLinks t)
|
|
-- ts
|
|
|
|
-- shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
|
|
-- shiftRoomTreeConstruction (Node t []) = [Node t []]
|
|
-- shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
|
|
-- zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
|
|
-- (_rmLinks t)
|
|
-- ts
|
|
-- where
|
|
-- f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a) r
|
|
-- where
|
|
-- (p,a) = last $ _rmLinks r
|
|
|
|
-- addTile :: Float -> Room -> Room
|
|
-- addTile z r
|
|
-- | not (null (_rmFloor r)) || null rp = r
|
|
-- | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
|
|
-- where
|
|
-- rp = _rmPolys r
|
|
-- poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp
|