Function for adding random lights to roomNGon
This commit is contained in:
+71
-72
@@ -1,25 +1,27 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Dodge.Layout (
|
||||
generateLevelFromRoomList,
|
||||
tilesFromRooms,
|
||||
shuffleRoomPos,
|
||||
) where
|
||||
|
||||
import qualified Data.Vector.Unboxed as UV
|
||||
--import Dodge.Path.Translate
|
||||
-- import Dodge.Path.Translate
|
||||
import qualified Control.Foldl as L
|
||||
import Control.Lens
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
--import Data.Graph.Inductive (labEdges, labNodes)
|
||||
import Data.List (nubBy,sortOn)
|
||||
import Linear
|
||||
-- import Data.Graph.Inductive (labEdges, labNodes)
|
||||
import Data.List (nubBy, sortOn)
|
||||
import Data.Maybe
|
||||
import Data.Tile
|
||||
--import Data.Traversable
|
||||
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.Item.Location.Initialize
|
||||
import Dodge.LevelGen.LevelStructure
|
||||
import Dodge.LevelGen.StaticWalls
|
||||
import Dodge.Path
|
||||
@@ -37,29 +39,27 @@ generateLevelFromRoomList gr' w =
|
||||
over gwWorld initWallZoning
|
||||
. over gwWorld randomCompass
|
||||
. over gwWorld setupWorldBounds
|
||||
-- . over (gwWorld . cWorld . lWorld) initItemLocations
|
||||
. doInPlacements
|
||||
-- . doOutPlacements
|
||||
. doIndividualPlacements
|
||||
. setTiles
|
||||
. worldToGenWorld rs'
|
||||
$ w & cWorld . lWorld . walls .~ wallsFromRooms 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
|
||||
& 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
|
||||
(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)
|
||||
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
|
||||
@@ -70,65 +70,61 @@ setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
|
||||
setTile :: Room -> GenWorld -> GenWorld
|
||||
setTile r gw = case _rmFloor r of
|
||||
Tiled{} -> gw
|
||||
InheritFloor -> gw
|
||||
& genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
|
||||
InheritFloor ->
|
||||
gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
|
||||
where
|
||||
t = case _rmMParent r of
|
||||
Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
|
||||
Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
|
||||
poly = orderPolygon . convexHullSafe
|
||||
. nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r
|
||||
poly =
|
||||
orderPolygon
|
||||
. convexHullSafe
|
||||
. nubBy ((==) `on` roundPoint2)
|
||||
. concat
|
||||
$ _rmPolys r
|
||||
|
||||
shuffleRoomPos :: RandomGen g => Room -> State g Room
|
||||
shuffleRoomPos :: (RandomGen g) => Room -> State g Room
|
||||
shuffleRoomPos = rmPos shuffle
|
||||
--shuffleRoomPos rm = do
|
||||
-- newPos <- shuffle $ _rmPos rm
|
||||
-- return $ rm & rmPos .~ newPos
|
||||
|
||||
doInPlacements :: GenWorld -> GenWorld
|
||||
doInPlacements w = foldl' (\gw (i,(_,f)) -> placeSpot i gw (f gw)) w
|
||||
. sortOn (fst.snd)
|
||||
$ foldMap g $ w ^. genRooms
|
||||
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)
|
||||
-- let (gw, rms) = mapAccumR doRoomInPlacements w (_genRooms w)
|
||||
-- in gw & genRooms .~ rms
|
||||
|
||||
--doRoomInPlacements :: GenWorld -> Room -> (GenWorld, Room)
|
||||
--doRoomInPlacements w rm = foldr f (w, rm) $ _rmInPmnt rm
|
||||
-- where
|
||||
-- f plf (w', r') = placeSpot (w', r') (plf w')
|
||||
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
|
||||
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
|
||||
PutChasm{} -> 0
|
||||
PutBlock{} -> 1
|
||||
PutDoor{} -> 2
|
||||
_ -> 3
|
||||
|
||||
--placeSpot' :: Int -> GenWorld -> Placement -> GenWorld
|
||||
--placeSpot' = placeSpot
|
||||
--placeSpot' i gw x =
|
||||
-- let (gw',r') = placeSpot (gw,(gw ^?! genRooms . ix i)) x
|
||||
-- in gw' & genRooms . ix i .~ r'
|
||||
|
||||
setupWorldBounds :: World -> World
|
||||
setupWorldBounds w =
|
||||
w & cWorld . cwGen . cwgWorldBounds
|
||||
%~ ( (bdMinX .~ f minx)
|
||||
. (bdMaxX .~ f maxx)
|
||||
. (bdMinY .~ f miny)
|
||||
. (bdMaxY .~ f maxy)
|
||||
)
|
||||
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)
|
||||
@@ -162,14 +158,17 @@ gameRoomFromRoom rm =
|
||||
GameRoom
|
||||
{ _grViewpoints =
|
||||
map doshift $
|
||||
_rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
|
||||
_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
|
||||
map doshift
|
||||
$ expandPolyCorners 50
|
||||
. convexHullSafe
|
||||
. nubBy closePoints
|
||||
. concat
|
||||
$ _rmBound rm ++ _rmPolys rm
|
||||
$ _rmBound rm ++ _rmPolys rm
|
||||
, _grRmBounds = map (map doshift) $ _rmBound rm
|
||||
, _grDir = getDir $ _rmPos rm
|
||||
, _grLinkDirs = mapMaybe undir $ _rmPos rm
|
||||
@@ -180,8 +179,8 @@ gameRoomFromRoom rm =
|
||||
doubleShift p a =
|
||||
map
|
||||
doshift
|
||||
[ p +.+ 10 *.* unitVectorAtAngle a
|
||||
, p -.- 10 *.* unitVectorAtAngle a
|
||||
[ p + 10 *^ unitVectorAtAngle a
|
||||
, p - 10 *^ unitVectorAtAngle a
|
||||
]
|
||||
filterUnusedLinks rp = case _rpType rp of
|
||||
UnusedLink{} -> Just $ _rpPos rp
|
||||
@@ -210,36 +209,36 @@ getTiles fl = case fl of
|
||||
Tiled xs -> xs
|
||||
_ -> error "tiles not correctly set for some room"
|
||||
|
||||
--divideWall :: Wall -> [Wall]
|
||||
--divideWall wl
|
||||
-- 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 =
|
||||
-- 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
|
||||
-- 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
|
||||
-- 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
|
||||
-- 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 $
|
||||
-- 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
|
||||
@@ -248,8 +247,8 @@ getTiles fl = case fl of
|
||||
-- where
|
||||
-- (p,a) = last $ _rmLinks r
|
||||
|
||||
--addTile :: Float -> Room -> Room
|
||||
--addTile z r
|
||||
-- addTile :: Float -> Room -> Room
|
||||
-- addTile z r
|
||||
-- | not (null (_rmFloor r)) || null rp = r
|
||||
-- | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
|
||||
-- where
|
||||
|
||||
Reference in New Issue
Block a user