Fix bug determining max radius of convex polys, fixes bugs in room positioning

src/Dodge/Tree/Shift.hs

@@ -1,8 +1,11 @@
 {- | Given a tree of rooms, tries to shift them into place in such a way that their
 links connect and that none of them clip.
 Creates a list of rooms; after this step the structure is determined by the actual positions of rooms.  -}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
 module Dodge.Tree.Shift
     ( positionRoomsFromTree
+    , PosRooms (..)
     ) where
 import Dodge.LevelGen.Data
 import Dodge.Room.Link
@@ -16,28 +19,37 @@ import LensHelp hiding (Empty, (<|) , (|>))
 
 import qualified Data.Set as S
 import Data.Tree
-import Data.Sequence hiding (zipWith)
+import qualified Data.Sequence as Seq
 import Data.List (delete)
 import Data.Bifunctor
+import Control.Lens
 
 type RoomInt = (Room,Int)
 
-positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
+data PosRooms = PosRooms
+    { _prBounds :: [ConvexPoly]
+    , _prRooms  :: [RoomInt]
+    }
+makeLenses ''PosRooms
+
+
+positionRoomsFromTree :: Tree RoomInt -> IO (Maybe PosRooms)
 positionRoomsFromTree (Node (r,i) ts) = printColumnTitles 
-    >> fmap (fmap (map $ first createUnusedLinkPos))
-        (posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty)
+    >> fmap (fmap (prRooms %~ (map $ first createUnusedLinkPos)))
+        (posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r',i) (zipCount ts) Empty)
   where
     r' = r & rmMID ?~ 0
 
-posRms :: [ConvexPoly]
+posRms :: PosRooms
     -> RoomInt
     -> [(Int,Tree RoomInt)]     -- the list of children, with indices
-    -> Seq (Tree RoomInt)
-    -> IO (Maybe [RoomInt])
-posRms bounds roomi [] st = case st of
-    Empty                   -> return $ Just [roomi]
-    Node nextroomi ts :<| tseq -> fmap (roomi:) <$> posRms bounds nextroomi (zipCount ts) tseq
-posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
+    -> Seq.Seq (Tree RoomInt)
+    -> IO (Maybe PosRooms)
+posRms prs roomi [] st = case st of
+    Empty                   -> return $ Just $ prs & prRooms .:~ roomi
+    Node nextroomi ts Seq.:<| tseq -> posRms (prs & prRooms .:~ roomi) nextroomi (zipCount ts) tseq
+    _ -> error "unexpected outcome in posRms"
+posRms prs parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
     printInfoCheckNum parenti numChild childi
     tryParentLinks outlinks
   where
@@ -54,7 +66,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
             | otherwise = do
                 putStrLn $ show j ++ "-" ++ show numinlink
                 mayrs <- posRms 
-                    (newBounds ++ bounds)
+                    (prs & prBounds .++~ newBounds)
                     (first updateparent parenti) 
                     its 
                     (tseq |> shiftedt)
@@ -64,7 +76,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
                         >> tryChildLinks ils
           where
             newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
-            clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
+            clipping = or (convexPolysOverlap <$> newBounds <*> _prBounds prs)
             updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
                 & rmLinks    %~ delete outlnk 
                 & rmPos      .:~ RoomPos