139 lines
4.3 KiB
Haskell
139 lines
4.3 KiB
Haskell
module Dodge.Layout
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.LevelGen
|
|
import Dodge.LevelGen.StaticWalls
|
|
--import Dodge.LevelGen.Data
|
|
import Dodge.Base
|
|
--import Dodge.RandomHelp
|
|
import Dodge.Graph
|
|
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
|
|
import Dodge.Room.Data
|
|
import Dodge.Default.Wall
|
|
import Geometry
|
|
import Dodge.Room.Link
|
|
import qualified IntMapHelp as IM
|
|
--import Dodge.Debug.LinkDecoration
|
|
import Picture.Data
|
|
import Tile
|
|
|
|
import Control.Monad.State
|
|
import Control.Lens
|
|
import System.Random
|
|
--import Data.List
|
|
--import Data.Maybe
|
|
import Data.Tree
|
|
import Data.Graph.Inductive.Graph (labNodes)
|
|
import qualified Data.Map as M
|
|
|
|
generateLevelFromRoomList :: State StdGen [Room] -> World -> World
|
|
generateLevelFromRoomList gr w = updateWallZoning
|
|
. placeSpots plmnts
|
|
-- . addRoomPolyDecorations rs
|
|
-- . addRoomLinkDecorations rs
|
|
$ w { _walls = wallsFromRooms rs
|
|
, _floorTiles = floorsFromRooms rs
|
|
}
|
|
where
|
|
plmnts = concatMap _rmPS rs
|
|
rs = evalState gr $ _randGen w
|
|
|
|
-- | connects a collection (tree) of rooms together
|
|
generateFromTree :: State StdGen (Tree Room) -> World -> World
|
|
generateFromTree t w = updateWallZoning $ placeSpots plmnts
|
|
$ w {_walls = wallsFromTree tr
|
|
,_pathGraph = path
|
|
,_pathGraph' = pairGraph
|
|
,_pathPoints = foldr insertPoint IM.empty (labNodes path)
|
|
,_pathInc = pinc
|
|
}
|
|
where
|
|
tr = evalState t $ _randGen w
|
|
plmnts = concatMap _rmPS $ flatten tr
|
|
path = pairsToGraph dist pairGraph
|
|
pairGraph = makePath tr
|
|
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
|
pinc = M.fromList $ pairsToIncidence pairGraph
|
|
|
|
updateWallZoning :: World -> World
|
|
updateWallZoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) w
|
|
where
|
|
wallInZone wl
|
|
| uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl
|
|
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
|
|
where
|
|
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
|
|
wlid = _wlID wl
|
|
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine 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
|
|
. foldr 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}
|
|
|
|
wallsFromRooms :: [Room] -> IM.IntMap Wall
|
|
wallsFromRooms =
|
|
-- divideWalls .
|
|
IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls
|
|
. foldr cutWalls [] . concatMap _rmPolys
|
|
where
|
|
f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
|
|
|
|
floorsFromRooms :: [Room] -> [RenderType]
|
|
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 foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls')
|
|
|
|
divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
|
divideWalls wls = IM.foldr 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 ( (0,0) -.- rotateV (pi-a) p , 0) $ shiftRoomBy ((0,0),pi-a) r
|
|
where
|
|
(p,a) = last $ _rmLinks r
|
|
|
|
|
|
|
|
|