justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Move to using RoomLink datatype

Browse Source
This commit is contained in:
justin
2021-11-23 20:45:39 +00:00
parent a66ea1d922
commit 1f2d767d5e
18 changed files with 160 additions and 122 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Debug/LinkDecoration.hs
+2 -1
View File
@@ -3,6 +3,7 @@ module Dodge.Debug.LinkDecoration
, addRoomPolyDecorations , addRoomPolyDecorations
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.RoomLink
--import Dodge.Base --import Dodge.Base
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.Picture.Layer import Dodge.Picture.Layer
@@ -22,7 +23,7 @@ addRoomLinkDecorations rms w = w & decorations %~
IM.insertWithNewKeys (map roomLinkDecorations rms) IM.insertWithNewKeys (map roomLinkDecorations rms)
roomLinkDecorations :: Room -> Picture roomLinkDecorations :: Room -> Picture
roomLinkDecorations rm = pictures . map linkDecoration $ _rmOutLinks rm ++ _rmInLinks rm roomLinkDecorations rm = pictures . map linkDecoration $ map lnkPosDir $ _rmOutLinks rm ++ _rmInLinks rm
linkDecoration :: (Point2,Float) -> Picture linkDecoration :: (Point2,Float) -> Picture
linkDecoration (p,a) = setLayer 1 . onLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)] linkDecoration (p,a) = setLayer 1 . onLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
src/Dodge/LevelGen/Data.hs
+5 -3
View File
@@ -7,6 +7,7 @@ import Geometry
import Shape.Data import Shape.Data
import Data.Tile import Data.Tile
import qualified Data.Set as S
import Control.Lens import Control.Lens
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
@@ -63,8 +64,8 @@ assigning no bounds will allow rooms to overlap.
-} -}
data Room = Room data Room = Room
{ _rmPolys :: [ [Point2] ] { _rmPolys :: [ [Point2] ]
, _rmOutLinks :: [(Point2,Float)] , _rmOutLinks :: [RoomLink]
, _rmInLinks :: [(Point2,Float)] , _rmInLinks :: [RoomLink]
-- update the room when assigning the next link to an adjacent room with the head of of this list, return the tail -- update the room when assigning the next link to an adjacent room with the head of of this list, return the tail
, _rmLinkEff :: [(Point2,Float) -> Room -> Room] , _rmLinkEff :: [(Point2,Float) -> Room -> Room]
, _rmPos :: [RoomPos] , _rmPos :: [RoomPos]
@@ -84,7 +85,7 @@ data Room = Room
, _rmEndWires :: IM.IntMap RoomWire , _rmEndWires :: IM.IntMap RoomWire
} }
data RoomLink = RoomLink data RoomLink = RoomLink
{ _rlType :: RoomLinkType { _rlType :: S.Set RoomLinkType
, _rlPos :: Point2 , _rlPos :: Point2
, _rlDir :: Float , _rlDir :: Float
} deriving (Eq,Ord) } deriving (Eq,Ord)
@@ -109,6 +110,7 @@ makeLenses ''Room
makeLenses ''PSType makeLenses ''PSType
makeLenses ''PlacementSpot makeLenses ''PlacementSpot
makeLenses ''Placement makeLenses ''Placement
makeLenses ''RoomLink
spNoID :: PlacementSpot -> PSType -> Placement spNoID :: PlacementSpot -> PSType -> Placement
spNoID ps pst = Placement ps pst Nothing (const Nothing) spNoID ps pst = Placement ps pst Nothing (const Nothing)
src/Dodge/Room/Airlock.hs
+11 -10
View File
@@ -3,6 +3,7 @@
module Dodge.Room.Airlock where module Dodge.Room.Airlock where
import Dodge.Placement.Instance import Dodge.Placement.Instance
import Dodge.Room.Foreground import Dodge.Room.Foreground
import Dodge.RoomLink
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Default.Wall import Dodge.Default.Wall
import Dodge.Data import Dodge.Data
@@ -23,8 +24,8 @@ airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ]
airlock0 :: Room airlock0 :: Room
airlock0 = defaultRoom airlock0 = defaultRoom
{ _rmPolys = [ rectNSWE 100 0 0 40 , rectNSWE 65 35 (-40) 20 ] { _rmPolys = [ rectNSWE 100 0 0 40 , rectNSWE 65 35 (-40) 20 ]
, _rmOutLinks = init lnks , _rmOutLinks = muout lnks
, _rmInLinks = [last lnks] , _rmInLinks = muin [last lnks]
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] , _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPmnts = , _rmPmnts =
[pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
@@ -46,8 +47,8 @@ airlockSimple :: Room
airlockSimple = defaultRoom airlockSimple = defaultRoom
{ _rmPolys = { _rmPolys =
[ rectNSWE 120 0 0 180 ] [ rectNSWE 120 0 0 180 ]
, _rmOutLinks = init lnks , _rmOutLinks = map (uncurry outLink) $init lnks
, _rmInLinks = [last lnks] , _rmInLinks = [uncurry inLink $ last lnks]
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks , _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
, _rmPmnts = , _rmPmnts =
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
@@ -70,8 +71,8 @@ airlockZ :: Room
airlockZ = defaultRoom airlockZ = defaultRoom
{ _rmPolys = { _rmPolys =
[ rectNSWE 120 0 0 180 ] [ rectNSWE 120 0 0 180 ]
, _rmOutLinks = [(V2 0 30,pi/2)] , _rmOutLinks = muout[(V2 0 30,pi/2)]
, _rmInLinks = [(V2 180 30,1.5*pi) ] , _rmInLinks = muin[(V2 180 30,1.5*pi) ]
, _rmPath = [] , _rmPath = []
-- [(V2 0 40,V2 40 0) -- [(V2 0 40,V2 40 0)
-- ,(V2 40 0,V2 0 40) -- ,(V2 40 0,V2 0 40)
@@ -108,8 +109,8 @@ airlock90 = defaultRoom
, (100,10) , (100,10)
] ]
] ]
, _rmOutLinks = [(V2 0 40,pi/2)] , _rmOutLinks = muout[(V2 0 40,pi/2)]
, _rmInLinks = [(V2 40 0,pi) ] , _rmInLinks = muin[(V2 40 0,pi) ]
, _rmPath = , _rmPath =
[(V2 0 40,V2 40 0) [(V2 0 40,V2 40 0)
,(V2 40 0,V2 0 40) ,(V2 40 0,V2 0 40)
@@ -141,8 +142,8 @@ airlockCrystal = defaultRoom
[ rectNSWE 140 0 0 40 [ rectNSWE 140 0 0 40
, orderPolygon $ map toV2 [ (39,20) , (150,60) , (150,80) , (39,120) ] , orderPolygon $ map toV2 [ (39,20) , (150,60) , (150,80) , (39,120) ]
] ]
, _rmOutLinks = [(V2 20 130,0) ] , _rmOutLinks = muout[(V2 20 130,0) ]
, _rmInLinks = [(V2 20 0 ,pi) ] , _rmInLinks = muin[(V2 20 0 ,pi) ]
, _rmPath = [ ] , _rmPath = [ ]
, _rmPmnts = , _rmPmnts =
[pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
src/Dodge/Room/Boss.hs
+9 -8
View File
@@ -2,6 +2,7 @@
module Dodge.Room.Boss module Dodge.Room.Boss
where where
import Dodge.Data import Dodge.Data
import Dodge.RoomLink
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Placement.Instance import Dodge.Placement.Instance
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
@@ -29,8 +30,8 @@ roomGlassOctogon x = createPathGrid $ defaultRoom
[rectNSWE x (-x) (-x) x [rectNSWE x (-x) (-x) x
,rectNSWE 0 (-(x + 40)) (-20) 20 ,rectNSWE 0 (-(x + 40)) (-20) 20
] ]
, _rmOutLinks = init lnks , _rmOutLinks = map (uncurry outLink) $ init lnks
, _rmInLinks = [last lnks] , _rmInLinks = [uncurry inLink $ last lnks]
, _rmPath = linksAndPath lnks , _rmPath = linksAndPath lnks
[ ( V2 0 x , V2 0 (-(x+40))) [ ( V2 0 x , V2 0 (-(x+40)))
, ( V2 0 (-(x+40)), V2 0 x) , ( V2 0 (-(x+40)), V2 0 x)
@@ -85,7 +86,7 @@ roomCross x y = defaultRoom
{ _rmPolys = [rectNSWE y (-y) (-x) x { _rmPolys = [rectNSWE y (-y) (-x) x
,rectNSWE (-x) x y (-y) ,rectNSWE (-x) x y (-y)
] ]
, _rmOutLinks = , _rmOutLinks = map (uncurry outLink)
[(V2 x (y-20),negate $ pi/2) [(V2 x (y-20),negate $ pi/2)
,(V2 x (20-y),negate $ pi/2) ,(V2 x (20-y),negate $ pi/2)
,(V2 (20-y) x ,0) ,(V2 (20-y) x ,0)
@@ -93,7 +94,7 @@ roomCross x y = defaultRoom
,(V2 (-x) (y-20),pi/2) ,(V2 (-x) (y-20),pi/2)
,(V2 (-x) (20-y),pi/2) ,(V2 (-x) (20-y),pi/2)
,(V2 (20-y) (-x),pi) ] ,(V2 (20-y) (-x),pi) ]
, _rmInLinks = [(V2 (y-20) (-x),pi) , _rmInLinks = [uncurry inLink $ (V2 (y-20) (-x),pi)
] ]
, _rmPath = [] , _rmPath = []
, _rmPmnts = , _rmPmnts =
@@ -120,8 +121,8 @@ roomShuriken x y =
] ] ] ]
corner = defaultRoom corner = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmOutLinks = [(V2 (x-1) (y-20),negate $ pi/2)] , _rmOutLinks = [uncurry outLink (V2 (x-1) (y-20),negate $ pi/2)]
, _rmInLinks = [(V2 (x-1) (y-20),negate $ pi/2)] , _rmInLinks = [uncurry inLink (V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = [] , _rmPath = []
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) x 70)] , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps , _rmBound = ps
@@ -146,8 +147,8 @@ roomTwistCross x y z =
] ]
corner = defaultRoom corner = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmOutLinks = [(V2 z (y-20), pi/2)] , _rmOutLinks = [toBothLnk (V2 z (y-20), pi/2)]
, _rmInLinks = [(V2 z (y-20), pi/2)] , _rmInLinks = [toBothLnk (V2 z (y-20), pi/2)]
, _rmPath = [] , _rmPath = []
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)] , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)]
, _rmBound = map (expandPolyCorners 10) ps , _rmBound = map (expandPolyCorners 10) ps
src/Dodge/Room/CheckConsistency.hs
+2 -1
View File
@@ -2,11 +2,12 @@ module Dodge.Room.CheckConsistency
where where
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.Graph import Dodge.Graph
import Dodge.RoomLink
linksOnPath :: Room -> Bool linksOnPath :: Room -> Bool
linksOnPath r = all pointOnPath linkPoints linksOnPath r = all pointOnPath linkPoints
where where
linkPoints = map fst $ _rmOutLinks r ++ _rmInLinks r linkPoints = map (fst . lnkPosDir) $ _rmOutLinks r ++ _rmInLinks r
pointOnPath p = elem p $ concatMap flat2 $ _rmPath r pointOnPath p = elem p $ concatMap flat2 $ _rmPath r
flat2 (x,y) = [x,y] flat2 (x,y) = [x,y]
src/Dodge/Room/Corridor.hs
+35 -23
View File
@@ -1,6 +1,7 @@
module Dodge.Room.Corridor module Dodge.Room.Corridor
where where
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.RoomLink
--import Dodge.Room.Foreground --import Dodge.Room.Foreground
import Dodge.Default.Room import Dodge.Default.Room
--import Dodge.LevelGen.Data --import Dodge.LevelGen.Data
@@ -16,8 +17,8 @@ import Data.Bifunctor
corridor :: Room corridor :: Room
corridor = defaultRoom corridor = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmOutLinks = init lnks , _rmOutLinks = init lnks'
, _rmInLinks = [last lnks] , _rmInLinks = [last lnks']
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPmnts = [ spanLightI (V2 0 40) (V2 40 40) ] , _rmPmnts = [ spanLightI (V2 0 40) (V2 40 40) ]
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
@@ -27,11 +28,17 @@ corridor = defaultRoom
} }
where where
poly = rectNSWE 80 0 0 40 poly = rectNSWE 80 0 0 40
lnks = map (first toV2) lnks' =
[((20,70) ,0) [uncurry outLink ((V2 20 70) ,0)
,((20,70), pi/6) ,uncurry outLink ((V2 20 70), pi/6)
,((20,70), negate $ pi/6) ,uncurry outLink ((V2 20 70), negate $ pi/6)
,((20,10) ,pi) ,uncurry inLink ((V2 20 10) ,pi)
]
lnks =
[ ((V2 20 70) ,0)
, ((V2 20 70), pi/6)
, ((V2 20 70), negate $ pi/6)
,((V2 20 10) ,pi)
] ]
keyholeCorridor :: Room keyholeCorridor :: Room
keyholeCorridor = corridor keyholeCorridor = corridor
@@ -54,8 +61,8 @@ corridorN = defaultRoom
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where lnks = [(V2 20 70 ,0) where lnks = [uncurry outLink (V2 20 70 ,0)
,(V2 20 10 ,pi) ,uncurry inLink (V2 20 10 ,pi)
] ]
pth = doublePair (V2 20 70,V2 20 10) pth = doublePair (V2 20 70,V2 20 10)
corridorWallN :: Room corridorWallN :: Room
@@ -68,8 +75,8 @@ corridorWallN = defaultRoom
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where lnks = [(V2 20 70 ,0) where lnks = [uncurry outLink(V2 20 70 ,0)
,(V2 20 10 ,pi) ,uncurry inLink(V2 20 10 ,pi)
] ]
pth = doublePair (V2 20 70,V2 20 10) pth = doublePair (V2 20 70,V2 20 10)
@@ -78,32 +85,37 @@ tEast = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20 { _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40 ,rectNSWE 80 40 (-40) 40
] ]
, _rmOutLinks = init lnks , _rmOutLinks = init lnks'
, _rmInLinks = [last lnks] , _rmInLinks = [last lnks']
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ] , _rmBound = [ rectNSWE 70 10 0 40 ]
} }
where where
lnks = map (first toV2) lnks =
[(( 30,60),-pi/2) [(V2 ( 30) (60),-pi/2)
,((-30,60),pi/2) ,(V2 (-30) (60),pi/2)
,((0,10),pi) ,((V2 0 10),pi)
]
lnks' =
[uncurry outLink(V2 ( 30) (60),-pi/2)
,uncurry outLink(V2 (-30) (60),pi/2)
,uncurry inLink((V2 0 10),pi)
] ]
tWest :: Room tWest :: Room
tWest = defaultRoom tWest = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20 { _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40 ,rectNSWE 80 40 (-40) 40
] ]
, _rmOutLinks = init lnks , _rmOutLinks = map (uncurry outLink) $ init lnks
, _rmInLinks = [last lnks] , _rmInLinks = [uncurry inLink $ last lnks]
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ] , _rmBound = [ rectNSWE 70 10 0 40 ]
} }
where where
lnks = map (first toV2) lnks =
[((-30,60),pi/2) [(V2 (-30) (60),pi/2)
,(( 30,60),-pi/2) ,(V2 ( 30) (60),-pi/2)
,((0,10),pi) ,(V2 (0) (10),pi)
] ]
src/Dodge/Room/Door.hs
+5 -4
View File
@@ -2,6 +2,7 @@
module Dodge.Room.Door module Dodge.Room.Door
where where
import Geometry import Geometry
import Dodge.RoomLink
import Dodge.Data import Dodge.Data
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Placement.Instance import Dodge.Placement.Instance
@@ -23,8 +24,8 @@ door = defaultRoom
-- note no bounds -- note no bounds
} }
where where
lnks = [(V2 20 35,0) lnks = [uncurry outLink (V2 20 35,0)
,(V2 20 5,pi) ,uncurry inLink (V2 20 5,pi)
] ]
switchDoorRoom :: Room switchDoorRoom :: Room
@@ -38,8 +39,8 @@ switchDoorRoom = defaultRoom
-- note no bounds -- note no bounds
} }
where where
lnks = [(V2 20 35,0) lnks = [uncurry outLink (V2 20 35,0)
,(V2 20 5,pi) ,uncurry inLink(V2 20 5,pi)
] ]
f (pmnt:_) = putDoubleDoor False red (cond pmnt) (V2 0 20) (V2 40 20) 2 f (pmnt:_) = putDoubleDoor False red (cond pmnt) (V2 0 20) (V2 40 20) 2
f _ = error "tried to put a door using an empty placement list" f _ = error "tried to put a door using an empty placement list"
src/Dodge/Room/Link.hs
+30 -24
View File
@@ -17,7 +17,7 @@ module Dodge.Room.Link
, changeLinkTo , changeLinkTo
, changeLinkFrom , changeLinkFrom
, randomiseOutLinks , randomiseOutLinks
, randomiseLinksBy -- , randomiseLinksBy
, invShiftLinkBy , invShiftLinkBy
, finalLinksUpdate , finalLinksUpdate
) where ) where
@@ -26,6 +26,7 @@ import Dodge.LevelGen.Data
import Dodge.RandomHelp import Dodge.RandomHelp
import Geometry import Geometry
import Data.Tile import Data.Tile
import Dodge.RoomLink
import System.Random import System.Random
import Control.Monad.State import Control.Monad.State
@@ -38,14 +39,14 @@ randomiseOutLinks r = do
return $ r {_rmOutLinks = newLinks } return $ r {_rmOutLinks = newLinks }
sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room
sortOutLinksOn f = rmOutLinks %~ sortOn f sortOutLinksOn f = overLnkType OutLink $ sortOn (f . lnkPosDir)
filterSortOutLinksOn :: Ord b => ((Point2,Float) -> Bool) -> ((Point2,Float) -> b) -> Room -> Room filterSortOutLinksOn :: Ord b => ((Point2,Float) -> Bool) -> ((Point2,Float) -> b) -> Room -> Room
filterSortOutLinksOn test f = rmOutLinks %~ dosort filterSortOutLinksOn test f = overLnkType OutLink dosort
where where
dosort [] = [] dosort [] = []
dosort xs = let (ys,zs) = partition test xs dosort xs = let (ys,zs) = partition (test . lnkPosDir) xs
in sortOn f ys ++ zs in sortOn (f . lnkPosDir) ys ++ zs
{- Shuffle all links of a room randomly. -} {- Shuffle all links of a room randomly. -}
randomiseAllLinks :: RandomGen g => Room -> State g Room randomiseAllLinks :: RandomGen g => Room -> State g Room
@@ -55,26 +56,26 @@ randomiseAllLinks r = do
, _rmInLinks = [head newLinks] , _rmInLinks = [head newLinks]
} }
randomiseLinksBy --randomiseLinksBy
:: ( [(Point2,Float)] -> State g [(Point2,Float)] ) -- :: ( [(Point2,Float)] -> State g [(Point2,Float)] )
-> Room -- -> Room
-> State g Room -- -> State g Room
randomiseLinksBy f r = do --randomiseLinksBy f r = do
newLinks <- f $ _rmOutLinks r ++ _rmInLinks r -- newLinks <- f $ _rmOutLinks r ++ _rmInLinks r
return $ r {_rmOutLinks = init newLinks -- return $ r {_rmOutLinks = init newLinks
, _rmInLinks = [last newLinks] -- , _rmInLinks = [last newLinks]
} -- }
-- TODO rename to filterOutLinks -- TODO rename to filterOutLinks
filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
filterLinks cond r = do filterLinks cond r = do
newLinks <- shuffle $ filter cond $ _rmOutLinks r newLinks <- shuffle $ filter (cond . lnkPosDir) $ _rmOutLinks r
return $ r {_rmOutLinks = newLinks} return $ r {_rmOutLinks = newLinks}
{- | Swaps the first link in the list with one that satisfies a given property. {- | Swaps the first link in the list with one that satisfies a given property.
- Does not change the last link in the list -} - Does not change the last link in the list -}
changeLinkFrom :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room changeLinkFrom :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
changeLinkFrom cond r = do changeLinkFrom cond r = do
let (possibleLnks,otherLnks) = partition cond $ _rmOutLinks r let (possibleLnks,otherLnks) = partition (cond . lnkPosDir) $ _rmOutLinks r
newLnks <- shuffle possibleLnks newLnks <- shuffle possibleLnks
return $ r {_rmOutLinks = newLnks ++ otherLnks} return $ r {_rmOutLinks = newLnks ++ otherLnks}
{- | Swaps the last link in the list with one that satisfies a given {- | Swaps the last link in the list with one that satisfies a given
@@ -83,7 +84,7 @@ changeLinkFrom cond r = do
changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
changeLinkTo cond r = do changeLinkTo cond r = do
let alllinks = _rmOutLinks r ++ _rmInLinks r let alllinks = _rmOutLinks r ++ _rmInLinks r
l <- takeOne $ filter cond alllinks l <- takeOne $ filter (cond . lnkPosDir) alllinks
let newLinks = delete l alllinks let newLinks = delete l alllinks
return $ r { _rmOutLinks = newLinks return $ r { _rmOutLinks = newLinks
,_rmInLinks = [l]} ,_rmInLinks = [l]}
@@ -98,7 +99,7 @@ shiftRoomToLink l r
$ shiftRoomBy (V2 0 0 -.- p , 0) $ shiftRoomBy (V2 0 0 -.- p , 0)
r r
where where
(p,a) = head $ _rmInLinks r (p,a) = lnkPosDir $ head $ _rmInLinks r
doRoomShift :: Room -> Room doRoomShift :: Room -> Room
doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm
@@ -111,7 +112,7 @@ shiftRoomBy shift r = r
& rmInLinks %~ fmap (shiftLinkBy shift) & rmInLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ map (shiftPathBy shift) & rmPath %~ map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift)) & rmBound %~ fmap (map (shiftPointBy shift))
& rmShift %~ shiftLinkBy shift & rmShift %~ shiftPosDirBy shift
& rmFloor %~ map & rmFloor %~ map
( (tilePoly %~ map (shiftPointBy shift)) ( (tilePoly %~ map (shiftPointBy shift))
. (tileZero %~ shiftPointBy shift ) . (tileZero %~ shiftPointBy shift )
@@ -138,10 +139,15 @@ shiftRoomShiftToLink' l inlink r
-- NOTE placements, when placed, will be shifted by the value _rmShift -- NOTE placements, when placed, will be shifted by the value _rmShift
shiftRoomShiftBy :: (Point2,Float) -> Room -> Room shiftRoomShiftBy :: (Point2,Float) -> Room -> Room
shiftRoomShiftBy shift r = r shiftRoomShiftBy shift r = r
& rmShift %~ shiftLinkBy shift & rmShift %~ shiftPosDirBy shift
shiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) shiftPosDirBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot) shiftPosDirBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftLinkBy :: (Point2,Float) -> RoomLink -> RoomLink
shiftLinkBy (pos,rot) = overLnkPosDir f
where
f (p,r) = (shiftPointBy (pos,rot) p, r + rot)
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot) invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
@@ -156,8 +162,8 @@ finalLinksUpdate :: Room -> Room
finalLinksUpdate rm = case _rmInLinks rm of finalLinksUpdate rm = case _rmInLinks rm of
(_:_) -> rm (_:_) -> rm
& rmInLinks %~ tail & rmInLinks %~ tail
& rmPos %~ ( (uncurry (UsedInLink 0) (head inlnks) :) & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir $ head inlnks) :)
. (map (uncurry UnusedLink) (outlnks ++ tail inlnks) ++) ) . (map (uncurry UnusedLink . lnkPosDir) (outlnks ++ tail inlnks) ++) )
_ -> rm _ -> rm
where where
inlnks = _rmInLinks rm inlnks = _rmInLinks rm
src/Dodge/Room/LongDoor.hs
+3 -2
View File
@@ -3,6 +3,7 @@
-} -}
module Dodge.Room.LongDoor where module Dodge.Room.LongDoor where
import Dodge.Data import Dodge.Data
import Dodge.RoomLink
import Dodge.Base import Dodge.Base
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
@@ -32,10 +33,10 @@ twinSlowDoorRoom
-> Room -> Room
twinSlowDoorRoom w h x = defaultRoom twinSlowDoorRoom w h x = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmOutLinks = , _rmOutLinks = map (uncurry outLink)
[ (V2 w (h/2) , negate $ pi/2) [ (V2 w (h/2) , negate $ pi/2)
, (V2 (-w) (h/2) , pi/2) ] , (V2 (-w) (h/2) , pi/2) ]
, _rmInLinks = [ (V2 0 (-h), pi) ] , _rmInLinks = [uncurry inLink (V2 0 (-h), pi) ]
, _rmPath = [] , _rmPath = []
, _rmPmnts = , _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
src/Dodge/Room/NoNeedWeapon.hs
+2 -1
View File
@@ -34,4 +34,5 @@ centerVaultExplosiveExit = do
,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll) ,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
] ]
r <- centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++) r <- centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++)
randomiseLinksBy shuffleTail r <&> rmOutLinks %~ take 2 --randomiseLinksBy shuffleTail r <&> rmOutLinks %~ take 2
return $ r & rmOutLinks %~ take 2
src/Dodge/Room/Path.hs
+6 -1
View File
@@ -1,12 +1,14 @@
module Dodge.Room.Path module Dodge.Room.Path
( gridPoints ( gridPoints
, linksAndPath , linksAndPath
, linksAndPath'
, makeGrid , makeGrid
, createPathGrid , createPathGrid
) )
where where
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.StaticWalls
import Dodge.RoomLink
import Geometry import Geometry
import Data.Function (on) import Data.Function (on)
@@ -18,7 +20,7 @@ import qualified Control.Foldl as L
createPathGrid :: Room -> Room createPathGrid :: Room -> Room
createPathGrid rm = rm createPathGrid rm = rm
{ _rmPath = linksAndPath (_rmOutLinks rm ++ _rmInLinks rm) filterGrid } { _rmPath = linksAndPath (map lnkPosDir $ _rmOutLinks rm ++ _rmInLinks rm) filterGrid }
where where
filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy
@@ -37,6 +39,9 @@ linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
where where
linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth) linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth)
linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath' = linksAndPath . map lnkPosDir
testCrossWalls testCrossWalls
:: [(Point2,Point2)] :: [(Point2,Point2)]
-> (Point2,Point2) -> (Point2,Point2)
src/Dodge/Room/Procedural.hs
+13 -13
View File
@@ -13,6 +13,7 @@ import Dodge.Data
import Dodge.Default.Wall import Dodge.Default.Wall
import Dodge.PlacementSpot import Dodge.PlacementSpot
import Dodge.Placement.Instance import Dodge.Placement.Instance
import Dodge.RoomLink
import Dodge.Item.Weapon.Utility import Dodge.Item.Weapon.Utility
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Room.Path import Dodge.Room.Path
@@ -66,8 +67,8 @@ roomRect x y xn yn = defaultRoom
wlnks = zip (map (+.+ V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2)) wlnks = zip (map (+.+ V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 ) nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi ) slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
lnks = nlnks ++ elnks ++ wlnks ++ slnks lnks = map toBothLnk $ nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn) pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -} {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
-- it is not clear to me that this works for very small rooms (but it does seem -- it is not clear to me that this works for very small rooms (but it does seem
-- to do so) -- to do so)
@@ -122,8 +123,8 @@ quarterRoomFlat w = do
] ]
pure $ defaultRoom pure $ defaultRoom
{ _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ] { _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ]
, _rmOutLinks = [(V2 0 w, 0)] , _rmOutLinks = [toBothLnk (V2 0 w, 0)]
, _rmInLinks = [(V2 0 w, 0)] , _rmInLinks = [toBothLnk (V2 0 w, 0)]
, _rmPath = concatMap doublePair , _rmPath = concatMap doublePair
[(V2 0 w,V2 0 (w-20)) [(V2 0 w,V2 0 (w-20))
,(V2 0 (w-20),V2 (w-20) (w-20)) ,(V2 0 (w-20),V2 (w-20) (w-20))
@@ -158,12 +159,12 @@ fourthCornerWall w = do
pure $ defaultRoom pure $ defaultRoom
{ _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ] { _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
, _rmOutLinks = , _rmOutLinks =
[(V2 (w/2) (3*w/2), negate $ pi/4) [toBothLnk (V2 (w/2) (3*w/2), negate $ pi/4)
,(V2 (negate $ w/2) (3*w/2), pi/4) ,toBothLnk (V2 (negate $ w/2) (3*w/2), pi/4)
] ]
, _rmInLinks = , _rmInLinks =
[(V2 (w/2) (3*w/2), negate $ pi/4) [toBothLnk (V2 (w/2) (3*w/2), negate $ pi/4)
,(V2 (negate $ w/2) (3*w/2), pi/4) ,toBothLnk (V2 (negate $ w/2) (3*w/2), pi/4)
] ]
, _rmPath = concatMap doublePair , _rmPath = concatMap doublePair
[(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20)) [(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20))
@@ -225,11 +226,10 @@ centerVaultRoom w h d = do
return $ defaultRoom return $ defaultRoom
{ _rmPolys = [rectNSWE h (-h) (-w) w] { _rmPolys = [rectNSWE h (-h) (-w) w]
, _rmOutLinks = , _rmOutLinks =
[(V2 0 h , 0 ) [outLink (V2 0 h) 0
,(V2 w 0 ,-pi/2) ,outLink (V2 w 0) (-pi/2)
,(V2 (-w) 0 , pi/2) ] ,outLink (V2 (-w) 0) (pi/2) ]
, _rmInLinks = [(V2 0 (-h), pi ) , _rmInLinks = [inLink (V2 0 (-h)) pi ]
]
, _rmPath = [] , _rmPath = []
, _rmPmnts = , _rmPmnts =
[sps0 $ PutWall (rectNSEW d (d - 30) d (d - 30)) defaultWall [sps0 $ PutWall (rectNSEW d (d - 30) d (d - 30)) defaultWall
src/Dodge/Room/RoadBlock.hs
+5 -4
View File
@@ -2,6 +2,7 @@
module Dodge.Room.RoadBlock module Dodge.Room.RoadBlock
where where
import Dodge.Data import Dodge.Data
import Dodge.RoomLink
import Geometry import Geometry
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
@@ -31,8 +32,8 @@ litCorridor90 = do
poly2 = rectNSWE (h-60) (h-100) (-60) 5 poly2 = rectNSWE (h-60) (h-100) (-60) 5
pure $ defaultRoom pure $ defaultRoom
{ _rmPolys = [poly,poly2] { _rmPolys = [poly,poly2]
, _rmOutLinks = [ (V2 40 (h - 80), -pi/2)] , _rmOutLinks = [uncurry outLink (V2 40 (h - 80), -pi/2)]
, _rmInLinks = [ (V2 20 0 , pi ) ] , _rmInLinks = [uncurry inLink (V2 20 0 , pi ) ]
, _rmPath = concatMap doublePair , _rmPath = concatMap doublePair
[( V2 20 0 , V2 20 (h-40) ) [( V2 20 0 , V2 20 (h-40) )
,( V2 0 (h-40) , V2 20 (h-40) ) ,( V2 0 (h-40) , V2 20 (h-40) )
@@ -94,8 +95,8 @@ lasTunnel :: Room
lasTunnel = defaultRoom lasTunnel = defaultRoom
{ _rmPolys = polys { _rmPolys = polys
, _rmBound = polys , _rmBound = polys
, _rmOutLinks = [(V2 20 190,1.5* pi)] , _rmOutLinks = [uncurry outLink(V2 20 190,1.5* pi)]
, _rmInLinks = [(V2 0 20,0.5* pi)] , _rmInLinks = [uncurry inLink(V2 0 20,0.5* pi)]
, _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 240) (1.5*pi) , _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 240) (1.5*pi)
, midWall (rectNSEW 65 40 0 25) , midWall (rectNSEW 65 40 0 25)
, mntLS vShape (V2 50 10) (V3 40 20 50) , mntLS vShape (V2 50 10) (V3 40 20 50)
src/Dodge/Room/Room.hs
+9 -8
View File
@@ -1,5 +1,6 @@
module Dodge.Room.Room where module Dodge.Room.Room where
import Dodge.Data import Dodge.Data
import Dodge.RoomLink
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Item.Weapon.BulletGuns import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Weapon.Launcher import Dodge.Item.Weapon.Launcher
@@ -48,8 +49,8 @@ roomC w h = do
roomPadCut :: [Point2] -> Point2 -> Room roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom roomPadCut ps p = defaultRoom
{ _rmPolys = [ps] { _rmPolys = [ps]
, _rmOutLinks = [(p,0)] , _rmOutLinks = muout [(p,0)]
, _rmInLinks = [(V2 0 0,pi)] , _rmInLinks = muin [(V2 0 0,pi)]
, _rmPath = [(V2 0 0,p)] , _rmPath = [(V2 0 0,p)]
} }
roomPillars :: Room roomPillars :: Room
@@ -201,8 +202,8 @@ roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst)
roomOctogon :: Room roomOctogon :: Room
roomOctogon = defaultRoom roomOctogon = defaultRoom
{ _rmPolys = [poly ] { _rmPolys = [poly ]
, _rmOutLinks = init lnks , _rmOutLinks = muout $ init lnks
, _rmInLinks = [last lnks] , _rmInLinks = muin [last lnks]
, _rmPath = allPairs $ map fst lnks -- this is too much , _rmPath = allPairs $ map fst lnks -- this is too much
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ] , _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
@@ -224,8 +225,8 @@ roomOctogon = defaultRoom
roomNgon :: Int -> Float -> Room roomNgon :: Int -> Float -> Room
roomNgon n x = defaultRoom roomNgon n x = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmOutLinks = init lnks , _rmOutLinks = muout $init lnks
, _rmInLinks = [last lnks] , _rmInLinks = muin[last lnks]
, _rmPath = [] -- TODO , _rmPath = [] -- TODO
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [poly] , _rmBound = [poly]
@@ -347,8 +348,8 @@ deadEndRoom :: Room
deadEndRoom = defaultRoom deadEndRoom = defaultRoom
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20 { _rmPolys = [rectNSWE 40 (-20) (-20) 20
] ]
, _rmOutLinks = init lnks , _rmOutLinks = muout $init lnks
, _rmInLinks = [last lnks] , _rmInLinks = muin $[last lnks]
, _rmPath = [] , _rmPath = []
, _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp] , _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30] , _rmBound = [rectNSWE 20 (-20) (-30) 30]
src/Dodge/Room/RunPast.hs
+2 -1
View File
@@ -1,5 +1,6 @@
module Dodge.Room.RunPast where module Dodge.Room.RunPast where
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.RoomLink
import Dodge.Data import Dodge.Data
import Dodge.Default import Dodge.Default
--import Dodge.Layout.Tree.Either --import Dodge.Layout.Tree.Either
@@ -70,7 +71,7 @@ runPastRoom i = do
,_rmPmnts = [] ,_rmPmnts = []
} }
switchdoor = switchDoorRoom & rmTakeFrom ?~ i switchdoor = switchDoorRoom & rmTakeFrom ?~ i
n = length $ filter theedgetest $ _rmOutLinks cenroom n = length $ filter theedgetest $ map lnkPosDir $ _rmOutLinks cenroom
controom = treeFromPost [PassDown switchdoor,PassDown linkcor] (UseAll door) controom = treeFromPost [PassDown switchdoor,PassDown linkcor] (UseAll door)
critrooms :: [SubCompTree Room] critrooms :: [SubCompTree Room]
critrooms = treeFromPost [PassDown switchdoor] (PassDown critroom) : critrooms = treeFromPost [PassDown switchdoor] (PassDown critroom) :
src/Dodge/Room/Start.hs
+4 -3
View File
@@ -2,6 +2,7 @@ module Dodge.Room.Start where
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
--import Dodge.PlacementSpot --import Dodge.PlacementSpot
import Dodge.Room.RunPast import Dodge.Room.RunPast
import Dodge.RoomLink
import Dodge.Room.LasTurret import Dodge.Room.LasTurret
import Dodge.Data import Dodge.Data
import Dodge.Default import Dodge.Default
@@ -135,7 +136,7 @@ rezBoxesWpCrit = do
centralRoom <- filterSortOutLinksOn bottomEdgeTest ((\(V2 a b) -> (b,a)) . fst) <$> centralRoom <- filterSortOutLinksOn bottomEdgeTest ((\(V2 a b) -> (b,a)) . fst) <$>
(randomiseOutLinks =<< changeLinkTo bottomPassDownTest (randomiseOutLinks =<< changeLinkTo bottomPassDownTest
((roomRectAutoLinks w h) {_rmPmnts = []})) ((roomRectAutoLinks w h) {_rmPmnts = []}))
let n = length $ filter bottomEdgeTest $ _rmOutLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmOutLinks centralRoom
i <- state $ randomR (0,n-3) i <- state $ randomR (0,n-3)
j <- state $ randomR (i,n-2) j <- state $ randomR (i,n-2)
blcor <- blockedCorridor' blcor <- blockedCorridor'
@@ -162,7 +163,7 @@ rezBoxesWp = do
centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest
((roomRectAutoLinks w h) {_rmPmnts = []}) ((roomRectAutoLinks w h) {_rmPmnts = []})
blcor <- blockedCorridor' blcor <- blockedCorridor'
let n = length $ filter bottomEdgeTest $ _rmOutLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmOutLinks centralRoom
let rezrooms = map adddoor let rezrooms = map adddoor
$ wpAdd theweapon aroom : replicate (n-2) aroom $ wpAdd theweapon aroom : replicate (n-2) aroom
centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom
@@ -183,7 +184,7 @@ rezBoxes = do
dbox = treeFromPost [PassDown door] (PassDown $ rezInvBox thecol) dbox = treeFromPost [PassDown door] (PassDown $ rezInvBox thecol)
centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest
((roomRectAutoLinks w h) {_rmPmnts = []}) ((roomRectAutoLinks w h) {_rmPmnts = []})
let n = length $ filter bottomEdgeTest $ _rmOutLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmOutLinks centralRoom
centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom
return $ treeFromTrunk [PassDown $ rezBox thecol return $ treeFromTrunk [PassDown $ rezBox thecol
, PassDown door , PassDown door
src/Dodge/Room/Treasure.hs
+2 -1
View File
@@ -5,6 +5,7 @@ Typically dead ends.
module Dodge.Room.Treasure module Dodge.Room.Treasure
where where
import Dodge.Data import Dodge.Data
import Dodge.RoomLink
import Dodge.Placement.Instance import Dodge.Placement.Instance
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
@@ -26,7 +27,7 @@ triLootRoom w h = pure $ defaultRoom
, base , base
] ]
, _rmOutLinks = [] , _rmOutLinks = []
, _rmInLinks = [(V2 0 (-80) , pi)] , _rmInLinks = [uncurry inLink(V2 0 (-80) , pi)]
, _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2)) , _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2))
, _rmPmnts = , _rmPmnts =
[sPS (V2 (15-w) 15 ) 0 $ PutID 0 [sPS (V2 (15-w) 15 ) 0 $ PutID 0
src/Dodge/Tree/Shift.hs
+5 -4
View File
@@ -7,6 +7,7 @@ module Dodge.Tree.Shift
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Tree.Polymorphic import Dodge.Tree.Polymorphic
import Dodge.RoomLink
import Geometry.ConvexPoly import Geometry.ConvexPoly
import Geometry.Data import Geometry.Data
import Padding import Padding
@@ -54,15 +55,15 @@ posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
where where
convexBounds = map pointsToPoly $ _rmBound r' convexBounds = map pointsToPoly $ _rmBound r'
clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
updateparent rm = doLnkEff l $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :) updateparent rm = doLnkEff (lnkPosDir l) $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir l) :)
l' = shiftLinkBy (_rmShift parent) l l' = shiftLinkBy (_rmShift parent) l
r' = doRoomShift . fst $ rootLabel shiftedt r' = doRoomShift . fst $ rootLabel shiftedt
updatechild rm = rm & rmInLinks %~ delete il updatechild rm = rm & rmInLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) il:) & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
. (map (uncurry UnusedLink) (_rmOutLinks rm ++ newInLinks) ++) ) . (map (uncurry UnusedLink . lnkPosDir) (_rmOutLinks rm ++ newInLinks) ++) )
where where
newInLinks = delete il $ _rmInLinks rm newInLinks = delete il $ _rmInLinks rm
shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' l' il) t shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' (lnkPosDir l') (lnkPosDir il)) t
printColumns :: [Int] -> [String] -> IO () printColumns :: [Int] -> [String] -> IO ()
printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs