Cleanup

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)]

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

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
+    = UsedOutLink 
-    | UsedInLink Int  Point2 Float
+        {_rpChildNum  :: Int 
-    | UnusedLink Point2 Float
+        ,_rpOutRoomID :: Int
-    | PosPl   Point2 Float
+        ,_rpPos :: Point2  
-    | LabPos  Int    RoomPos
+        ,_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)

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

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 = 

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 , 0)
-        ,uncurry outLink ((V2 20 70), pi/6)
+        ,uncurry outLink (V2 20 70 , pi/6)
-        ,uncurry outLink ((V2 20 70), negate $ pi/6)
+        ,uncurry outLink (V2 20 70 , negate $ pi/6)
-        ,uncurry inLink ((V2 20 10)    ,pi)
+        ,uncurry inLink  (V2 20 10 , pi)
         ]
     lnks =
-        [ ((V2 20 70)  ,0::Float)
+        [ (V2 20 70, 0::Float)
-        , ((V2 20 70), pi/6)
+        , (V2 20 70, pi/6)
-        , ((V2 20 70), negate $ pi/6)
+        , (V2 20 70, negate $ pi/6)
-        ,((V2 20 10)    ,pi)
+        , (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)::Float)
-        ,(V2 (-30) (60),pi/2)
+        ,(V2 (-30) 60, pi/2 )
-        ,((V2 0 10),pi)
+        ,(V2    0  10, pi   )
         ]
     lnks' =
-        [uncurry outLink(V2 ( 30) (60),-pi/2)
+        [uncurry outLink (V2   30   60,-pi/2)
-        ,uncurry outLink(V2 (-30) (60),pi/2)
+        ,uncurry outLink (V2 (-30)  60,pi/2)
-        ,uncurry inLink((V2 0 10),pi)
+        ,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)
-        ,outLink (V2 ( 30) (60)) (-pi/2)
+        ,outLink (V2   30  60) (-pi/2)
-        ,inLink  (V2 (0) (10)) pi
+        ,inLink  (V2    0  10)   pi
         ]

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 :: (Point2,Float) -> (Point2,Float) -> Room -> Room
-shiftRoomShiftToLink' l inlink r 
+shiftRoomShiftToLink l inlink r 
     = shiftRoomShiftBy l 
     . shiftRoomShiftBy (V2 0 0       , pi-a)  
     $ shiftRoomShiftBy (V2 0 0 -.- p , 0) 

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)]
+    , _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)
+    , _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)
         ]

src/Dodge/RoomPos.hs

@@ -3,9 +3,4 @@ import Dodge.LevelGen.Data
 import Geometry
 
 extractRoomPos :: RoomPos -> (Point2,Float)
-extractRoomPos rp = case rp of
+extractRoomPos rp = (_rpPos rp,_rpDir rp)
-    UsedOutLink _  p a -> (p,a)
-    UsedInLink  _  p a -> (p,a)
-    UnusedLink p a -> (p,a)
-    PosPl      p a -> (p,a)
-    LabPos _ rp'   -> extractRoomPos rp'

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'
+            newBounds = map pointsToPoly $ _rmBound r'
-            clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
+            clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
             updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
-                & rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir outlnk) :)
+                & rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :)
-            l' = shiftLinkBy (_rmShift parent) 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