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

Cleanup

Browse Source
This commit is contained in:
justin
2021-11-23 21:48:01 +00:00
parent b7d6eeaa84
commit 86f363c2f9
19 changed files with 93 additions and 122 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Debug/LinkDecoration.hs
+1 -1
View File
@@ -23,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 $ map lnkPosDir $ _rmOutLinks rm ++ _rmInLinks rm roomLinkDecorations rm = pictures . map linkDecoration $ map lnkPosDir $ _rmLinks 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/Default/Room.hs
+1 -2
View File
@@ -7,9 +7,8 @@ import qualified Data.IntMap.Strict as IM
defaultRoom :: Room defaultRoom :: Room
defaultRoom = Room defaultRoom = Room
{ _rmPolys = [] { _rmPolys = []
, _rmOutLinks = [] , _rmLinks = []
, _rmLinkEff = [] , _rmLinkEff = []
, _rmInLinks = []
, _rmPos = [] , _rmPos = []
, _rmPath = [] , _rmPath = []
, _rmPmnts = [] , _rmPmnts = []
src/Dodge/LevelGen/Data.hs
+5 -6
View File
@@ -53,19 +53,18 @@ data Placement = Placement
| RandomPlacement {_unRandomPlacement :: State StdGen Placement} | RandomPlacement {_unRandomPlacement :: State StdGen Placement}
{- {- The '_rmPolys' lists which polygons should be cut out to form the indestructible walls of the room.
The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room.
Link pairs contain a position and rotation to attach to another room; Link pairs contain a position and rotation to attach to another room;
0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc. 0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc.
TODO : Explain path, does it need both directions? TODO : Explain path, does it need both directions?
Placement spots allow things to be put in the room during level generation. Placement spots allow things to be put in the room during level generation.
Room bounds between a new room and previously placed rooms are checked during level generation, Room bounds between a new room and previously placed rooms are checked during level generation,
assigning no bounds will allow rooms to overlap. assigning no bounds will allow rooms to overlap. -}
-}
data Room = Room data Room = Room
{ _rmPolys :: [ [Point2] ] { _rmPolys :: [ [Point2] ]
, _rmOutLinks :: [RoomLink] , _rmLinks :: [RoomLink]
, _rmInLinks :: [RoomLink] --, _rmOutLinks :: [RoomLink]
--, _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]
src/Dodge/Room/Airlock.hs
+5 -10
View File
@@ -24,8 +24,7 @@ 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 = muout lnks , _rmLinks = muout lnks ++ muin [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)
@@ -47,8 +46,7 @@ airlockSimple :: Room
airlockSimple = defaultRoom airlockSimple = defaultRoom
{ _rmPolys = { _rmPolys =
[ rectNSWE 120 0 0 180 ] [ rectNSWE 120 0 0 180 ]
, _rmOutLinks = map (uncurry outLink) $init lnks , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ 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)
@@ -71,8 +69,7 @@ airlockZ :: Room
airlockZ = defaultRoom airlockZ = defaultRoom
{ _rmPolys = { _rmPolys =
[ rectNSWE 120 0 0 180 ] [ rectNSWE 120 0 0 180 ]
, _rmOutLinks = muout[(V2 0 30,pi/2)] , _rmLinks = muout[(V2 0 30,pi/2)] ++ muin[(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)
@@ -109,8 +106,7 @@ airlock90 = defaultRoom
, (100,10) , (100,10)
] ]
] ]
, _rmOutLinks = muout[(V2 0 40,pi/2)] , _rmLinks = muout[(V2 0 40,pi/2)] ++ muin[(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)
@@ -142,8 +138,7 @@ 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 = muout[(V2 20 130,0) ] , _rmLinks = muout[(V2 20 130,0) ] ++ muin[(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
+7 -9
View File
@@ -30,8 +30,7 @@ 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 = map (uncurry outLink) $ init lnks , _rmLinks = (map (uncurry outLink) $ init lnks) ++ [uncurry inLink $ 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)
@@ -86,15 +85,16 @@ 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 = map (uncurry outLink) , _rmLinks = 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)
,(V2 (y-20) x ,0) ,(V2 (y-20) x ,0)
,(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 = [uncurry inLink $ (V2 (y-20) (-x),pi) ] ++
[uncurry inLink $ (V2 (y-20) (-x),pi)
] ]
, _rmPath = [] , _rmPath = []
, _rmPmnts = , _rmPmnts =
@@ -121,8 +121,7 @@ roomShuriken x y =
] ] ] ]
corner = defaultRoom corner = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmOutLinks = [uncurry outLink (V2 (x-1) (y-20),negate $ pi/2)] , _rmLinks = [toBothLnk (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
@@ -147,8 +146,7 @@ roomTwistCross x y z =
] ]
corner = defaultRoom corner = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmOutLinks = [toBothLnk (V2 z (y-20), pi/2)] , _rmLinks = [toBothLnk (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
+1 -1
View File
@@ -7,7 +7,7 @@ import Dodge.RoomLink
linksOnPath :: Room -> Bool linksOnPath :: Room -> Bool
linksOnPath r = all pointOnPath linkPoints linksOnPath r = all pointOnPath linkPoints
where where
linkPoints = map (fst . lnkPosDir) $ _rmOutLinks r ++ _rmInLinks r linkPoints = map (fst . lnkPosDir) $ _rmLinks 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
+11 -15
View File
@@ -17,8 +17,7 @@ import Tile
corridor :: Room corridor :: Room
corridor = defaultRoom corridor = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmOutLinks = init lnks' , _rmLinks = 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 ]
@@ -55,8 +54,7 @@ corridorN :: Room
corridorN = defaultRoom corridorN = defaultRoom
{ _rmPolys = [rectNSWE 80 0 0 40 { _rmPolys = [rectNSWE 80 0 0 40
] ]
, _rmOutLinks = init lnks , _rmLinks = lnks
, _rmInLinks = [last lnks]
, _rmPath = pth , _rmPath = pth
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
@@ -69,13 +67,13 @@ corridorWallN :: Room
corridorWallN = defaultRoom corridorWallN = defaultRoom
{ _rmPolys = [rectNSWE 70 0 0 40 { _rmPolys = [rectNSWE 70 0 0 40
] ]
, _rmOutLinks = init lnks , _rmLinks = lnks
, _rmInLinks = [last lnks]
, _rmPath = pth , _rmPath = pth
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where lnks = [uncurry outLink(V2 20 70 ,0) where
lnks = [uncurry outLink(V2 20 70 ,0)
,uncurry inLink(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)
@@ -85,8 +83,7 @@ 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' , _rmLinks = 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 ]
@@ -107,15 +104,14 @@ 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 = map (uncurry outLink) $ init lnks , _rmLinks = lnks
, _rmInLinks = [uncurry inLink $ last lnks] , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) $ map lnkPosDir 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 = lnks =
[(V2 (-30) (60),pi/2) [outLink (V2 (-30) (60)) (pi/2)
,(V2 ( 30) (60),-pi/2) ,outLink (V2 ( 30) (60)) (-pi/2)
,(V2 (0) (10),pi) ,inLink (V2 (0) (10)) pi
] ]
src/Dodge/Room/Door.hs
+2 -4
View File
@@ -16,8 +16,7 @@ import Control.Lens
door :: Room door :: Room
door = defaultRoom door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40] { _rmPolys = [rectNSWE 40 0 0 40]
, _rmOutLinks = init lnks , _rmLinks = init lnks ++ [last lnks]
, _rmInLinks = [last lnks]
, _rmPath = [(V2 20 35,V2 20 5)] , _rmPath = [(V2 20 35,V2 20 5)]
-- door extends into side walls (for shadows as rendered 12/03) -- door extends into side walls (for shadows as rendered 12/03)
, _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)] , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
@@ -31,8 +30,7 @@ door = defaultRoom
switchDoorRoom :: Room switchDoorRoom :: Room
switchDoorRoom = defaultRoom switchDoorRoom = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40] { _rmPolys = [rectNSWE 40 0 0 40]
, _rmOutLinks = init lnks , _rmLinks = init lnks++ [last lnks]
, _rmInLinks = [last lnks]
, _rmPath = [(V2 20 35,V2 20 5)] , _rmPath = [(V2 20 35,V2 20 5)]
, _rmPartPmnt = Just f , _rmPartPmnt = Just f
-- door extends into side walls (for shadows as rendered 12/03) -- door extends into side walls (for shadows as rendered 12/03)
src/Dodge/Room/Link.hs
+29 -28
View File
@@ -19,7 +19,7 @@ module Dodge.Room.Link
, randomiseOutLinks , randomiseOutLinks
-- , randomiseLinksBy -- , randomiseLinksBy
, invShiftLinkBy , invShiftLinkBy
, finalLinksUpdate --, finalLinksUpdate
) where ) where
import Dodge.Placement.PlaceSpot import Dodge.Placement.PlaceSpot
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
@@ -32,11 +32,13 @@ import System.Random
import Control.Monad.State import Control.Monad.State
import Control.Lens import Control.Lens
import Data.List import Data.List
import qualified Data.Set as S
{- Shuffle the initial links of a room randomly. -} {- Shuffle the initial links of a room randomly. -}
randomiseOutLinks :: RandomGen g => Room -> State g Room randomiseOutLinks :: RandomGen g => Room -> State g Room
randomiseOutLinks r = do randomiseOutLinks r = do
newLinks <- shuffle $ _rmOutLinks r let (outs,xs) = partition (S.member OutLink . _rlType) $ _rmLinks r
return $ r {_rmOutLinks = newLinks } newLinks <- shuffle outs
return $ r {_rmLinks = newLinks ++ xs }
sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room
sortOutLinksOn f = overLnkType OutLink $ sortOn (f . lnkPosDir) sortOutLinksOn f = overLnkType OutLink $ sortOn (f . lnkPosDir)
@@ -48,13 +50,12 @@ filterSortOutLinksOn test f = overLnkType OutLink dosort
dosort xs = let (ys,zs) = partition (test . lnkPosDir) xs dosort xs = let (ys,zs) = partition (test . lnkPosDir) xs
in sortOn (f . lnkPosDir) ys ++ zs in sortOn (f . lnkPosDir) ys ++ zs
{- Shuffle all links of a room randomly. -} {- Shuffle the order of all links of a room randomly.
- Note this does not change their types. -}
randomiseAllLinks :: RandomGen g => Room -> State g Room randomiseAllLinks :: RandomGen g => Room -> State g Room
randomiseAllLinks r = do randomiseAllLinks r = do
newLinks <- shuffle $ _rmOutLinks r ++ _rmInLinks r newLinks <- shuffle $ _rmLinks r
return $ r {_rmOutLinks = tail newLinks return $ r {_rmLinks = newLinks }
, _rmInLinks = [head newLinks]
}
--randomiseLinksBy --randomiseLinksBy
-- :: ( [(Point2,Float)] -> State g [(Point2,Float)] ) -- :: ( [(Point2,Float)] -> State g [(Point2,Float)] )
@@ -66,28 +67,29 @@ randomiseAllLinks r = do
-- , _rmInLinks = [last newLinks] -- , _rmInLinks = [last newLinks]
-- } -- }
-- 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 . lnkPosDir) $ _rmOutLinks r newLinks <- shuffle $ filter (cond . lnkPosDir) $ _rmLinks r
return $ r {_rmOutLinks = newLinks} return $ r {_rmLinks = 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 -}
-- TODO replace all instances of this with something more sensible
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 . lnkPosDir) $ _rmOutLinks r let (possibleLnks,otherLnks) = partition (cond . lnkPosDir) $ _rmLinks r
newLnks <- shuffle possibleLnks newLnks <- shuffle possibleLnks
return $ r {_rmOutLinks = newLnks ++ otherLnks} return $ r {_rmLinks = 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
- property (it might swap with itself). Unsafe. - property (it might swap with itself). Unsafe.
- Be careful about calling this after changeLinkFrom. -} - Be careful about calling this after changeLinkFrom. -}
-- TODO replace with something more sensible
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 = _rmLinks r
l <- takeOne $ filter (cond . lnkPosDir) alllinks l <- takeOne $ filter (cond . lnkPosDir) alllinks
let l' = l & rlType .~ S.singleton InLink
let newLinks = delete l alllinks let newLinks = delete l alllinks
return $ r { _rmOutLinks = newLinks return $ r & rmLinks .~ (l':newLinks)
,_rmInLinks = [l]}
{- | Move a room so that the first link in '_rmInLinks' lines up to {- | Move a room so that the first link in '_rmInLinks' lines up to
an external point and direction. an external point and direction.
This is intended to work when the external point is an outgoing link from another room. This is intended to work when the external point is an outgoing link from another room.
@@ -108,8 +110,7 @@ doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm
shiftRoomBy :: (Point2,Float) -> Room -> Room shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift r = r shiftRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift)) & rmPolys %~ fmap (map (shiftPointBy shift))
& rmOutLinks %~ fmap (shiftLinkBy shift) & rmLinks %~ 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 %~ shiftPosDirBy shift & rmShift %~ shiftPosDirBy shift
@@ -158,13 +159,13 @@ shiftPathBy
-> (Point2,Point2) -> (Point2,Point2)
shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2) shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
finalLinksUpdate :: Room -> Room --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) (lnkPosDir $ head inlnks) :) -- & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir $ head inlnks) :)
. (map (uncurry UnusedLink . lnkPosDir) (outlnks ++ tail inlnks) ++) ) -- . (map (uncurry UnusedLink . lnkPosDir) (outlnks ++ tail inlnks) ++) )
_ -> rm -- _ -> rm
where -- where
inlnks = _rmInLinks rm -- inlnks = _rmInLinks rm
outlnks = _rmOutLinks rm -- outlnks = _rmOutLinks rm
src/Dodge/Room/LongDoor.hs
+2 -2
View File
@@ -33,10 +33,10 @@ twinSlowDoorRoom
-> Room -> Room
twinSlowDoorRoom w h x = defaultRoom twinSlowDoorRoom w h x = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmOutLinks = map (uncurry outLink) , _rmLinks = 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 = [uncurry inLink (V2 0 (-h), pi) ] ++ [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 -2
View File
@@ -33,6 +33,6 @@ centerVaultExplosiveExit = do
,sPS (V2 0 120) 0 $ PutCrit explosiveBarrel ,sPS (V2 0 120) 0 $ PutCrit explosiveBarrel
,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 ++) 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
+1 -1
View File
@@ -20,7 +20,7 @@ import qualified Control.Foldl as L
createPathGrid :: Room -> Room createPathGrid :: Room -> Room
createPathGrid rm = rm createPathGrid rm = rm
{ _rmPath = linksAndPath (map lnkPosDir $ _rmOutLinks rm ++ _rmInLinks rm) filterGrid } { _rmPath = linksAndPath (map lnkPosDir $ _rmLinks 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
src/Dodge/Room/Procedural.hs
+7 -14
View File
@@ -47,8 +47,7 @@ roomRect
-> Room -> Room
roomRect x y xn yn = defaultRoom roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ] { _rmPolys = [rectNSWE y 0 0 x ]
, _rmOutLinks = init lnks , _rmLinks = init lnks ++ [last lnks]
, _rmInLinks = [last lnks]
, _rmPath = concatMap doublePair pth , _rmPath = concatMap doublePair pth
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
@@ -85,8 +84,7 @@ Mostly involves concatenation. -}
combineRooms :: Room -> Room -> Room combineRooms :: Room -> Room -> Room
combineRooms r r' = defaultRoom combineRooms r r' = defaultRoom
{ _rmPolys = _rmPolys r ++ _rmPolys r' { _rmPolys = _rmPolys r ++ _rmPolys r'
, _rmOutLinks = _rmOutLinks r ++ _rmOutLinks r' , _rmLinks = _rmLinks r ++ _rmLinks r'
, _rmInLinks = _rmInLinks r ++ _rmInLinks r'
, _rmPath = map clampPath $ _rmPath r , _rmPath = map clampPath $ _rmPath r
++ _rmPath r' ++ _rmPath r'
, _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r) , _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r)
@@ -123,8 +121,7 @@ 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 = [toBothLnk (V2 0 w, 0)] , _rmLinks = [toBothLnk (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,11 +155,7 @@ 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 = , _rmLinks =
[toBothLnk (V2 (w/2) (3*w/2), negate $ pi/4)
,toBothLnk (V2 (negate $ w/2) (3*w/2), pi/4)
]
, _rmInLinks =
[toBothLnk (V2 (w/2) (3*w/2), negate $ pi/4) [toBothLnk (V2 (w/2) (3*w/2), negate $ pi/4)
,toBothLnk (V2 (negate $ w/2) (3*w/2), pi/4) ,toBothLnk (V2 (negate $ w/2) (3*w/2), pi/4)
] ]
@@ -225,11 +218,11 @@ centerVaultRoom
centerVaultRoom w h d = do centerVaultRoom w h d = do
return $ defaultRoom return $ defaultRoom
{ _rmPolys = [rectNSWE h (-h) (-w) w] { _rmPolys = [rectNSWE h (-h) (-w) w]
, _rmOutLinks = , _rmLinks =
[outLink (V2 0 h) 0 [outLink (V2 0 h) 0
,outLink (V2 w 0) (-pi/2) ,outLink (V2 w 0) (-pi/2)
,outLink (V2 (-w) 0) (pi/2) ] ,outLink (V2 (-w) 0) (pi/2)
, _rmInLinks = [inLink (V2 0 (-h)) pi ] , 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
+2 -4
View File
@@ -32,8 +32,7 @@ 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 = [uncurry outLink (V2 40 (h - 80), -pi/2)] , _rmLinks = [uncurry outLink (V2 40 (h - 80), -pi/2)] ++ [uncurry inLink (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) )
@@ -95,8 +94,7 @@ lasTunnel :: Room
lasTunnel = defaultRoom lasTunnel = defaultRoom
{ _rmPolys = polys { _rmPolys = polys
, _rmBound = polys , _rmBound = polys
, _rmOutLinks = [uncurry outLink(V2 20 190,1.5* pi)] , _rmLinks = [uncurry outLink(V2 20 190,1.5* pi)] ++ [uncurry inLink(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
+6 -9
View File
@@ -49,8 +49,7 @@ 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 = muout [(p,0)] , _rmLinks = muout [(p,0)] ++ muin [(V2 0 0,pi)]
, _rmInLinks = muin [(V2 0 0,pi)]
, _rmPath = [(V2 0 0,p)] , _rmPath = [(V2 0 0,p)]
} }
roomPillars :: Room roomPillars :: Room
@@ -202,8 +201,7 @@ roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst)
roomOctogon :: Room roomOctogon :: Room
roomOctogon = defaultRoom roomOctogon = defaultRoom
{ _rmPolys = [poly ] { _rmPolys = [poly ]
, _rmOutLinks = muout $ init lnks , _rmLinks = muout (init lnks) ++ muin [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)] ]
@@ -225,8 +223,7 @@ roomOctogon = defaultRoom
roomNgon :: Int -> Float -> Room roomNgon :: Int -> Float -> Room
roomNgon n x = defaultRoom roomNgon n x = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmOutLinks = muout $init lnks , _rmLinks = muout (init lnks) ++ muin[last lnks]
, _rmInLinks = muin[last lnks]
, _rmPath = [] -- TODO , _rmPath = [] -- TODO
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [poly] , _rmBound = [poly]
@@ -306,7 +303,8 @@ weaponBehindPillar = do
rcp <- roomCenterPillar rcp <- roomCenterPillar
return $ treeFromTrunk return $ treeFromTrunk
[PassDown corridor [PassDown corridor
,PassDown $ over rmOutLinks tail $ over rmPmnts (++ plmnts1) rcp --,PassDown $ over rmOutLinks tail $ over rmPmnts (++ plmnts1) rcp
,PassDown $ over rmPmnts (++ plmnts1) rcp
] ]
(singleUseAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN) (singleUseAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
@@ -348,8 +346,7 @@ deadEndRoom :: Room
deadEndRoom = defaultRoom deadEndRoom = defaultRoom
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20 { _rmPolys = [rectNSWE 40 (-20) (-20) 20
] ]
, _rmOutLinks = muout $init lnks , _rmLinks = muout (init lnks) ++ muin [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
+1 -1
View File
@@ -71,7 +71,7 @@ runPastRoom i = do
,_rmPmnts = [] ,_rmPmnts = []
} }
switchdoor = switchDoorRoom & rmTakeFrom ?~ i switchdoor = switchDoorRoom & rmTakeFrom ?~ i
n = length $ filter theedgetest $ map lnkPosDir $ _rmOutLinks cenroom n = length $ filter theedgetest $ map lnkPosDir $ _rmLinks 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
+3 -3
View File
@@ -136,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 $ map lnkPosDir $ _rmOutLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks 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'
@@ -163,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 $ map lnkPosDir $_rmOutLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmLinks 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
@@ -184,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 $ map lnkPosDir $_rmOutLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmLinks 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
+1 -2
View File
@@ -26,8 +26,7 @@ triLootRoom w h = pure $ defaultRoom
{ _rmPolys = [ tri { _rmPolys = [ tri
, base , base
] ]
, _rmOutLinks = [] , _rmLinks = [uncurry inLink(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 -7
View File
@@ -35,11 +35,11 @@ posRms bounds (parent,_) _ [] st = case st of
-> fmap (parent:) <$> posRms bounds childi 0 ts tseq -> fmap (parent:) <$> posRms bounds childi 0 ts tseq
posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
printInfoCheckNum parenti numChild childi printInfoCheckNum parenti numChild childi
tryParentLinks (0::Int) (_rmOutLinks parent) tryParentLinks (0::Int) (rmOutLinks parent)
where where
tryParentLinks _ [] = putStrLn "no viable link pairs, backtrack" >> return Nothing tryParentLinks _ [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
tryParentLinks j (l:ls) = do tryParentLinks j (l:ls) = do
tryChildLinks (0::Int) (_rmInLinks $ fst childi) tryChildLinks (0::Int) (rmInLinks $ fst childi)
where where
tryChildLinks _ [] = tryParentLinks (j+1) ls tryChildLinks _ [] = tryParentLinks (j+1) ls
tryChildLinks numinlink (il:ils) tryChildLinks numinlink (il:ils)
@@ -55,14 +55,12 @@ 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 (lnkPosDir l) $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir l) :) updateparent rm = doLnkEff (lnkPosDir l) $ rm & rmLinks %~ 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 & rmLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):) & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
. (map (uncurry UnusedLink . lnkPosDir) (_rmOutLinks rm ++ newInLinks) ++) ) . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
where
newInLinks = delete il $ _rmInLinks rm
shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' (lnkPosDir l') (lnkPosDir il)) t shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' (lnkPosDir l') (lnkPosDir il)) t
printColumns :: [Int] -> [String] -> IO () printColumns :: [Int] -> [String] -> IO ()