232 lines
8.0 KiB
Haskell
232 lines
8.0 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Layout
|
|
( generateLevelFromRoomList
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Path
|
|
import Dodge.ShiftPoint
|
|
import Dodge.Placement.PlaceSpot
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.LevelGen.StaticWalls
|
|
import Dodge.Room.Foreground
|
|
import Dodge.Wall.Zone
|
|
import Dodge.GameRoom
|
|
import Dodge.Bounds
|
|
import Dodge.Default.Wall
|
|
import Dodge.Room.Link
|
|
import Geometry
|
|
import Geometry.Vector3D
|
|
import Geometry.ConvexPoly
|
|
import qualified IntMapHelp as IM
|
|
import Tile
|
|
import Dodge.RandomHelp
|
|
import Color
|
|
import Shape
|
|
--import Padding
|
|
|
|
import Data.List (nubBy)
|
|
import Data.Traversable
|
|
import Control.Lens
|
|
import System.Random
|
|
import Data.Foldable
|
|
import qualified Control.Foldl as L
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import Control.Monad.State
|
|
|
|
generateLevelFromRoomList :: [Room] -> World -> World
|
|
generateLevelFromRoomList gr' w
|
|
= initWallZoning
|
|
. setupWorldBounds
|
|
. placeWires
|
|
. doPartialPlacements
|
|
. doExtendedPlacements
|
|
. flip (mapAccumR doRoomPlacements) rs'
|
|
$ w { _walls = wallsFromRooms rs
|
|
, _floorTiles = floorsFromRooms rs
|
|
, _gameRooms = gameRoomsFromRooms rs'
|
|
, _pathGraph = path
|
|
, _pathGraphP = pairPath
|
|
}
|
|
where
|
|
path = pairsToGraph dist pairPath
|
|
pairPath = concatMap _rmPath rs
|
|
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
|
|
rs = map doRoomShift rs'
|
|
rs' = mapM shuffleRoomPos (zipWith addTile zs gr') & evalState $ _randGen w
|
|
|
|
shuffleRoomPos :: RandomGen g => Room -> State g Room
|
|
shuffleRoomPos rm = do
|
|
newPos <- shuffle $ _rmPos rm
|
|
return $ rm & rmPos .~ newPos
|
|
|
|
placeWires :: (World,[Room])-> World
|
|
placeWires (w,rms) = foldr placeRoomWires w rms
|
|
|
|
placeRoomWires :: Room -> World -> World
|
|
placeRoomWires rm w = IM.foldr ($) w
|
|
$ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)
|
|
|
|
placeWire :: Room -> RoomWire -> RoomWire -> World -> World
|
|
placeWire rm (WallWire p a h) wr = placeWire rm wr (RoomWire p a) .
|
|
(foregroundShape %~ (colorSH red (barPP 1.5 (addZ h p') (addZ 80 p')) <>)
|
|
)
|
|
where
|
|
p' = shiftPointBy (_rmShift rm) p
|
|
placeWire rm rw1 rw2@WallWire{} = placeWire rm rw2 rw1
|
|
placeWire rm (RoomWire p _) (RoomWire q _) = foregroundShape
|
|
%~ ((col $ thinHighBarChain 80 $ map (shiftPointBy rs) doOrdering) <>)
|
|
where
|
|
--TODO use rmWalls for non convex rooms
|
|
--rmWalls = foldr cutWalls [] (_rmPolys rm)
|
|
doOrdering = orderPolygonAround rmcen (p:q:ps)
|
|
col | clockwise = colorSH red
|
|
| otherwise = colorSH red
|
|
rmps = concat $ _rmPolys rm
|
|
rmcen = centroid rmps
|
|
clockwise = isLHS rmcen p q
|
|
ps | clockwise = filter leftprightq rmps
|
|
| otherwise = filter rightpleftq rmps
|
|
leftprightq x = isLHS rmcen p x && isRHS rmcen q x
|
|
rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
|
|
rs = _rmShift rm
|
|
|
|
doPartialPlacements :: ( (IM.IntMap [Placement],World) , [Room] ) -> (World,[Room])
|
|
doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms
|
|
|
|
doPartialPlacement :: IM.IntMap [Placement] -> World -> Room -> (World, Room)
|
|
doPartialPlacement im w rm = case _rmPartPmnt rm of
|
|
Nothing -> (w, rm)
|
|
Just fi -> case _rmTakeFrom rm of
|
|
Nothing -> (w, rm)
|
|
Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i))
|
|
|
|
doExtendedPlacements :: (World,[Room]) -> ( (IM.IntMap [Placement], World) , [Room] )
|
|
doExtendedPlacements (w,rms) = mapAccumR doExtendedPlacement (IM.empty,w) rms
|
|
|
|
doExtendedPlacement :: (IM.IntMap [Placement], World) -> Room
|
|
-> ( (IM.IntMap [Placement], World) , Room )
|
|
doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of
|
|
Nothing -> ( (im,w) , rm )
|
|
Just plmnt -> case _rmLabel rm of
|
|
Nothing -> ( (im,w) , rm )
|
|
Just i -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt
|
|
in ( (IM.insert i plmnts im, neww) , newrm )
|
|
|
|
doRoomPlacements :: World -> Room -> (World, Room)
|
|
doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
|
|
|
|
setupWorldBounds :: World -> World
|
|
setupWorldBounds w = w
|
|
& worldBounds . bdMinX .~ f minx
|
|
& worldBounds . bdMaxX .~ f maxx
|
|
& worldBounds . bdMinY .~ f miny
|
|
& worldBounds . bdMaxY .~ f maxy
|
|
where
|
|
f = fromMaybe 0
|
|
ps = IM.map (fst . _wlLine) $ _walls 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
|
|
|
|
--polyhedrasToEdges :: [Polyhedra] -> [Point3]
|
|
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
|
|
|
|
initWallZoning :: World -> World
|
|
initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w)
|
|
|
|
--makePath :: Tree Room -> [(Point2,Point2)]
|
|
--makePath = concatMap _rmPath . flatten
|
|
|
|
wallsFromRooms :: [Room] -> IM.IntMap Wall
|
|
wallsFromRooms =
|
|
-- divideWalls .
|
|
IM.fromList . 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 = map gameRoomFromRoom
|
|
|
|
gameRoomFromRoom :: Room -> GameRoom
|
|
gameRoomFromRoom rm = GameRoom
|
|
{ _grViewpoints = map doshift $ _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
|
|
-- ++ map fst (_rmLinks rm)
|
|
, _grViewpointsEx = concatMap unpos (_rmPos rm)
|
|
, _grBound = map doshift $ expandPolyCorners 50 . convexHullSafe . nubBy closePoints
|
|
. concat $ _rmBound rm ++ _rmPolys 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
|
|
]
|
|
unpos (OutLink _ p a) = doubleShift p a
|
|
unpos (InLink p a) = doubleShift p a
|
|
unpos _ = []
|
|
undir (OutLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
|
|
undir (InLink _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
|
|
undir _ = Nothing
|
|
closePoints x y = roundPoint2 x == roundPoint2 y
|
|
getDir (InLink _ a:_) = a + snd (_rmShift rm)
|
|
getDir (_:xs) = getDir xs
|
|
getDir _ = 0 -- fallback
|
|
|
|
floorsFromRooms :: [Room] -> [(Point3,Point3)]
|
|
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
|
|
|
|
--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
|