Move towards more usable placements
This commit is contained in:
+61
-64
@@ -1,34 +1,29 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Layout
|
||||
where
|
||||
( generateLevelFromRoomList
|
||||
, doPartialPlacements
|
||||
, doExtendedPlacements
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LevelGen.StaticWalls
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Dodge.Wall.Zone
|
||||
import Dodge.Zone
|
||||
import Dodge.GameRoom
|
||||
import Dodge.Bounds
|
||||
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
|
||||
import Dodge.Room.Data
|
||||
import Dodge.Room.AddTile
|
||||
import Dodge.Default.Wall
|
||||
import Geometry
|
||||
--import Geometry.Data
|
||||
import Dodge.Room.Link
|
||||
import qualified IntMapHelp as IM
|
||||
--import Dodge.Debug.LinkDecoration
|
||||
import Picture.Data
|
||||
import Tile
|
||||
import Polyhedra
|
||||
import Polyhedra.Data
|
||||
|
||||
import Data.List (nubBy)
|
||||
--import Control.Monad.State
|
||||
import Control.Lens
|
||||
import System.Random
|
||||
import Data.Tree
|
||||
--import Data.Graph.Inductive.Graph (labNodes)
|
||||
--import qualified Data.Map as M
|
||||
import Data.Foldable
|
||||
@@ -52,13 +47,29 @@ generateLevelFromRoomList gr w
|
||||
rs = zipWith addTile zs gr
|
||||
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
|
||||
|
||||
doPartialPlacements :: [Room] -> (IM.IntMap Int,World) -> World
|
||||
doPartialPlacements rms (im,w) = foldr (doPartialPlacement im) w rms
|
||||
|
||||
doPartialPlacement :: IM.IntMap Int -> Room -> World -> World
|
||||
doPartialPlacement im rm w = case _rmPartialPmnt rm of
|
||||
Nothing -> w
|
||||
Just fi -> case _rmTakeFrom rm of
|
||||
Nothing -> w
|
||||
Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i))
|
||||
|
||||
doExtendedPlacements :: [Room] -> World -> (IM.IntMap Int, World)
|
||||
doExtendedPlacements rms w = foldr doExtendedPlacement (IM.empty,w) rms
|
||||
|
||||
doExtendedPlacement :: Room -> (IM.IntMap Int, World) -> (IM.IntMap Int, World)
|
||||
doExtendedPlacement rm (im,w) = case _rmExtendedPmnt rm of
|
||||
Nothing -> (im,w)
|
||||
Just _ -> case _rmLabel rm of
|
||||
Nothing -> (im,w)
|
||||
Just _ -> undefined
|
||||
|
||||
doRoomPlacements :: World -> Room -> World
|
||||
doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPmnts rm
|
||||
|
||||
updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
|
||||
updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
|
||||
updatePSLnkUsing _ ps = ps
|
||||
|
||||
setupWorldBounds :: World -> World
|
||||
setupWorldBounds w = w
|
||||
& worldBounds . bdMinX .~ f minx
|
||||
@@ -75,8 +86,8 @@ setupWorldBounds w = w
|
||||
<*> L.premap sndV2 L.maximum
|
||||
) ps
|
||||
|
||||
polyhedrasToEdges :: [Polyhedra] -> [Point3]
|
||||
polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
|
||||
--polyhedrasToEdges :: [Polyhedra] -> [Point3]
|
||||
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
|
||||
|
||||
initWallZoning :: World -> World
|
||||
initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w)
|
||||
@@ -84,22 +95,8 @@ initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~
|
||||
-- where
|
||||
-- wallInZone wl = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
|
||||
|
||||
makePath :: Tree Room -> [(Point2,Point2)]
|
||||
makePath = concatMap _rmPath . flatten
|
||||
|
||||
-- consider nubbing walls after dividing them
|
||||
wallsFromTree :: Tree Room -> IM.IntMap Wall
|
||||
wallsFromTree t =
|
||||
-- createInnerWalls
|
||||
divideWalls
|
||||
. assignKeys
|
||||
. removeInverseWalls
|
||||
. foldl' (flip cutWalls) [] -- map (map (g . roundPoint2))
|
||||
-- . map (map roundPoint2)
|
||||
$ concatMap _rmPolys (flatten t)
|
||||
where
|
||||
assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
|
||||
f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
|
||||
--makePath :: Tree Room -> [(Point2,Point2)]
|
||||
--makePath = concatMap _rmPath . flatten
|
||||
|
||||
wallsFromRooms :: [Room] -> IM.IntMap Wall
|
||||
wallsFromRooms =
|
||||
@@ -132,40 +129,40 @@ gameRoomsFromRooms = map f
|
||||
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)
|
||||
--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')
|
||||
--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
|
||||
-- where f _ = IM.insert 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
|
||||
-- $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
|
||||
-- (_rmLinks t)
|
||||
-- ts
|
||||
|
||||
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
|
||||
--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
|
||||
|
||||
Reference in New Issue
Block a user