From 5f6d81bd0580fe5583fec965221ad86dbf71649a Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 23 Nov 2021 22:33:23 +0000 Subject: [PATCH] Cleanup --- src/Dodge/Debug/LinkDecoration.hs | 2 +- src/Dodge/Layout.hs | 4 ++-- src/Dodge/LevelGen/Data.hs | 26 ++++++++++++++++----- src/Dodge/PlacementSpot.hs | 6 ++--- src/Dodge/Room/Boss.hs | 4 ++-- src/Dodge/Room/Corridor.hs | 39 ++++++++++++++++--------------- src/Dodge/Room/Link.hs | 6 ++--- src/Dodge/Room/RoadBlock.hs | 8 ++++--- src/Dodge/RoomPos.hs | 7 +----- src/Dodge/Tree/Shift.hs | 16 ++++++------- 10 files changed, 65 insertions(+), 53 deletions(-) diff --git a/src/Dodge/Debug/LinkDecoration.hs b/src/Dodge/Debug/LinkDecoration.hs index c2567a651..91bcdba28 100644 --- a/src/Dodge/Debug/LinkDecoration.hs +++ b/src/Dodge/Debug/LinkDecoration.hs @@ -23,7 +23,7 @@ addRoomLinkDecorations rms w = w & decorations %~ IM.insertWithNewKeys (map roomLinkDecorations rms) roomLinkDecorations :: Room -> Picture -roomLinkDecorations rm = pictures . map linkDecoration $ map lnkPosDir $ _rmLinks rm +roomLinkDecorations rm = pictures . map (linkDecoration . lnkPosDir) $ _rmLinks rm linkDecoration :: (Point2,Float) -> Picture linkDecoration (p,a) = setLayer 1 . onLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index aeafbe239..611d9e098 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -168,10 +168,10 @@ gameRoomFromRoom rm = GameRoom [p +.+ 10 *.* unitVectorAtAngle a ,p -.- 10 *.* unitVectorAtAngle a ] - unpos (UsedOutLink _ p a) = doubleShift p a + unpos (UsedOutLink _ _ p a) = doubleShift p a unpos (UsedInLink _ p a) = doubleShift p a unpos _ = [] - undir (UsedOutLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm) + undir (UsedOutLink _ _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm) undir (UsedInLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm) undir _ = Nothing closePoints x y = roundPoint2 x == roundPoint2 y diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 2fdbcf9f5..c805964a7 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -91,18 +91,31 @@ data RoomLink = RoomLink data RoomLinkType = OutLink | InLink - | AnyLink | LabLink Int deriving (Eq,Ord) data RoomWire = --RoomWire Point2 Float WallWire Point2 Float Float data RoomPos - = UsedOutLink Int Point2 Float - | UsedInLink Int Point2 Float - | UnusedLink Point2 Float - | PosPl Point2 Float - | LabPos Int RoomPos + = UsedOutLink + {_rpChildNum :: Int + ,_rpOutRoomID :: Int + ,_rpPos :: Point2 + ,_rpDir :: Float + } + | UsedInLink + {_rpInRoomID :: Int + ,_rpPos :: Point2 + ,_rpDir ::Float + } + | UnusedLink + {_rpPos :: Point2 + ,_rpDir ::Float + } + | PosPl + {_rpPos :: Point2 + ,_rpDir ::Float + } deriving (Eq,Ord,Show) makeLenses ''Room @@ -110,6 +123,7 @@ makeLenses ''PSType makeLenses ''PlacementSpot makeLenses ''Placement makeLenses ''RoomLink +makeLenses ''RoomPos spNoID :: PlacementSpot -> PSType -> Placement spNoID ps pst = Placement ps pst Nothing (const Nothing) diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index 35cf2b5d4..1edd4f4a1 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -15,13 +15,13 @@ anyLnkOutPS = PSPos f (const id) Nothing atFstLnkOut :: PlacementSpot atFstLnkOut = PSPos f (const id) Nothing where - f (UsedOutLink 0 p a) = Just (PS p a, UsedOutLink 0 p a) + f (UsedOutLink 0 i p a) = Just (PS p a, UsedOutLink 0 i p a) f _ = Nothing atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing where - f (UsedOutLink i p a) | n == i = Just (PS p' a', UsedOutLink n p a) + f (UsedOutLink i rmid p a) | n == i = Just (PS p' a', UsedOutLink n rmid p a) where (p',a') = theshift (p,a) f _ = Nothing @@ -40,7 +40,7 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f overFstLnkOut :: PlacementSpot overFstLnkOut = PSPos f (const id) Nothing where - f (UsedOutLink 0 p a) = Just (PS p a, PosPl p a) + f (UsedOutLink 0 _ p a) = Just (PS p a, PosPl p a) f _ = Nothing anyLnkInPS :: Float -- ^ amount to shift inward diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index ab4894961..da9dddfa6 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -30,7 +30,7 @@ roomGlassOctogon x = createPathGrid $ defaultRoom [rectNSWE x (-x) (-x) x ,rectNSWE 0 (-(x + 40)) (-20) 20 ] - , _rmLinks = (map (uncurry outLink) $ init lnks) ++ [uncurry inLink $ last lnks] + , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks] , _rmPath = linksAndPath lnks [ ( V2 0 x , V2 0 (-(x+40))) , ( V2 0 (-(x+40)), V2 0 x) @@ -94,7 +94,7 @@ roomCross x y = defaultRoom ,(V2 (-x) (20-y),pi/2) ,(V2 (20-y) (-x),pi) ] ++ - [uncurry inLink $ (V2 (y-20) (-x),pi) + [uncurry inLink (V2 (y-20) (-x),pi) ] , _rmPath = [] , _rmPmnts = diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index 4c14497d5..d1a02a775 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.Corridor where import Dodge.LevelGen.Data @@ -19,7 +20,7 @@ corridor = defaultRoom { _rmPolys = [poly] , _rmLinks = 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 ] , _rmFloor = [makeTileFromPoly poly 2] , _rmRandPSs = [psRandRanges (10,30) (30,60) (0,2*pi)] @@ -28,16 +29,16 @@ corridor = defaultRoom where poly = rectNSWE 80 0 0 40 lnks' = - [uncurry outLink ((V2 20 70) ,0) - ,uncurry outLink ((V2 20 70), pi/6) - ,uncurry outLink ((V2 20 70), negate $ pi/6) - ,uncurry inLink ((V2 20 10) ,pi) + [uncurry outLink (V2 20 70 , 0) + ,uncurry outLink (V2 20 70 , pi/6) + ,uncurry outLink (V2 20 70 , negate $ pi/6) + ,uncurry inLink (V2 20 10 , pi) ] lnks = - [ ((V2 20 70) ,0::Float) - , ((V2 20 70), pi/6) - , ((V2 20 70), negate $ pi/6) - ,((V2 20 10) ,pi) + [ (V2 20 70, 0::Float) + , (V2 20 70, pi/6) + , (V2 20 70, negate $ pi/6) + , (V2 20 10, pi) ] keyholeCorridor :: Room keyholeCorridor = corridor @@ -90,14 +91,14 @@ tEast = defaultRoom } where lnks = - [(V2 ( 30) (60),(-pi/2)::Float) - ,(V2 (-30) (60),pi/2) - ,((V2 0 10),pi) + [(V2 30 60, (-pi/2)::Float) + ,(V2 (-30) 60, pi/2 ) + ,(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) + [uncurry outLink (V2 30 60,-pi/2) + ,uncurry outLink (V2 (-30) 60,pi/2) + ,uncurry inLink (V2 0 10,pi) ] tWest :: Room tWest = defaultRoom @@ -105,13 +106,13 @@ tWest = defaultRoom ,rectNSWE 80 40 (-40) 40 ] , _rmLinks = lnks - , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) $ map lnkPosDir lnks + , _rmPath = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks , _rmPmnts = [] , _rmBound = [ rectNSWE 70 10 0 40 ] } where lnks = - [outLink (V2 (-30) (60)) (pi/2) - ,outLink (V2 ( 30) (60)) (-pi/2) - ,inLink (V2 (0) (10)) pi + [outLink (V2 (-30) 60) ( pi/2) + ,outLink (V2 30 60) (-pi/2) + ,inLink (V2 0 10) pi ] diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 605e8e46c..db9443b99 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -6,7 +6,7 @@ the outgoing links. -} module Dodge.Room.Link ( --shiftRoomToLink --, shiftRoomShiftToLink - shiftRoomShiftToLink' + shiftRoomShiftToLink , shiftRoomBy , shiftLinkBy , doRoomShift @@ -129,8 +129,8 @@ shiftRoomBy shift r = r -- where -- (p,a) = head $ _rmInLinks r -shiftRoomShiftToLink' :: (Point2,Float) -> (Point2,Float) -> Room -> Room -shiftRoomShiftToLink' l inlink r +shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room +shiftRoomShiftToLink l inlink r = shiftRoomShiftBy l . shiftRoomShiftBy (V2 0 0 , pi-a) $ shiftRoomShiftBy (V2 0 0 -.- p , 0) diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index ea26466e1..2c9ebf1da 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -32,7 +32,9 @@ litCorridor90 = do poly2 = rectNSWE (h-60) (h-100) (-60) 5 pure $ defaultRoom { _rmPolys = [poly,poly2] - , _rmLinks = [uncurry outLink (V2 40 (h - 80), -pi/2)] ++ [uncurry inLink (V2 20 0 , pi ) ] + , _rmLinks = + [ outLink (V2 40 (h - 80)) (-pi/2) + , inLink (V2 20 0 ) pi ] , _rmPath = concatMap doublePair [( V2 20 0 , V2 20 (h-40) ) ,( V2 0 (h-40) , V2 20 (h-40) ) @@ -94,8 +96,8 @@ lasTunnel :: Room lasTunnel = defaultRoom { _rmPolys = polys , _rmBound = polys - , _rmLinks = [uncurry outLink(V2 20 190,1.5* pi)] ++ [uncurry inLink(V2 0 20,0.5* pi)] - , _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 240) (1.5*pi) + , _rmLinks = [outLink (V2 20 190) (1.5* pi), inLink (V2 0 20) (0.5* pi)] + , _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 240) (1.5*pi) , midWall (rectNSEW 65 40 0 25) , mntLS vShape (V2 50 10) (V3 40 20 50) ] diff --git a/src/Dodge/RoomPos.hs b/src/Dodge/RoomPos.hs index e21c830c2..d122ddfc7 100644 --- a/src/Dodge/RoomPos.hs +++ b/src/Dodge/RoomPos.hs @@ -3,9 +3,4 @@ import Dodge.LevelGen.Data import Geometry extractRoomPos :: RoomPos -> (Point2,Float) -extractRoomPos rp = case rp of - UsedOutLink _ p a -> (p,a) - UsedInLink _ p a -> (p,a) - UnusedLink p a -> (p,a) - PosPl p a -> (p,a) - LabPos _ rp' -> extractRoomPos rp' +extractRoomPos rp = (_rpPos rp,_rpDir rp) diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index bd3d15da8..fbf94a7b5 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -41,26 +41,26 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do where tryChildLinks [] = tryParentLinks ls tryChildLinks ((numinlink,il):ils) - | clipping = tryChildLinks ils + | clipping = tryChildLinks ils | otherwise = do putStrLn $ show j ++ "-"++show numinlink - mayrs <- posRms (convexBounds ++ bounds) + mayrs <- posRms (newBounds ++ bounds) (first updateparent parenti) its (tseq |> shiftedt) case mayrs of Just rms -> return $ Just rms Nothing -> printInfo parenti numChild childi >> tryChildLinks ils where - convexBounds = map pointsToPoly $ _rmBound r' - clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) + newBounds = map pointsToPoly $ _rmBound r' + clipping = or (convexPolysOverlap <$> newBounds <*> bounds) updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm - & rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir outlnk) :) - l' = shiftLinkBy (_rmShift parent) outlnk + & rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :) + shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk r' = doRoomShift . fst $ rootLabel shiftedt updatechild rm = rm & rmLinks %~ delete il & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):) . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) ) - shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' (lnkPosDir l') (lnkPosDir il)) t + shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) t zipCount :: [a] -> [(Int,a)] zipCount = Prelude.zip [0..] @@ -85,7 +85,7 @@ printInfo (parentrm,parenti) childn (childrm,childi) = do printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO () printInfoCheckNum p 0 c = printInfo p 0 c printInfoCheckNum _ childn (childrm,childi) = do - putStr $ rpns 20 ("") + putStr $ rpns 20 "" ++ rpns 5 (show childn ++ " ") ++ rpns 20 (_rmName childrm ++ "-" ++ show childi ) where