73 lines
2.7 KiB
Haskell
73 lines
2.7 KiB
Haskell
{- | 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. -}
|
|
module Dodge.Tree.Shift
|
|
( positionRoomsFromTree
|
|
) where
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.Room.Link
|
|
import Dodge.Tree.Polymorphic
|
|
import Geometry.ConvexPoly
|
|
import Geometry.Data
|
|
import Padding
|
|
|
|
import Data.Tree
|
|
import Data.Sequence hiding (zipWith)
|
|
import Data.List (delete)
|
|
import Data.Bifunctor
|
|
import Control.Lens hiding (Empty, (<|) , (|>))
|
|
|
|
type RoomInt = (Room,Int)
|
|
|
|
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room])
|
|
positionRoomsFromTree (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty
|
|
|
|
posRms :: [ConvexPoly]
|
|
-> RoomInt
|
|
-> Int -- ^ the number of children already placed
|
|
-> [Tree RoomInt]
|
|
-> Seq (Tree RoomInt)
|
|
-> IO (Maybe [Room])
|
|
posRms bounds (parent,_) _ [] st = case st of
|
|
Empty -> return $ Just [parent]
|
|
Node childi ts :<| tseq
|
|
-> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq
|
|
posRms bounds parenti numChild (t@(Node childi _):ts) tseq = do
|
|
printInfo parenti numChild childi
|
|
tryLinks (0::Int) (init $ _rmLinks parent)
|
|
where
|
|
parent = fst parenti
|
|
tryLinks _ [] = putStrLn "all links tried" >> return Nothing
|
|
tryLinks j (l:ls)
|
|
| clipping = tryLinks (j+1) ls
|
|
| otherwise = do
|
|
putStrLn $ "placed at link " ++ show j
|
|
mayrs <- posRms (convexBounds ++ bounds)
|
|
(first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
|
|
case mayrs of
|
|
Nothing -> do
|
|
putStr "Backtrack: "
|
|
printInfo parenti numChild childi
|
|
tryLinks (j+1) ls
|
|
Just rs -> return (Just rs)
|
|
where
|
|
convexBounds = map pointsToPoly $ _rmBound r'
|
|
clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
|
|
upr rm = doLnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :)
|
|
l' = shiftLinkBy (_rmShift parent) l
|
|
r' = doRoomShift . fst $ rootLabel shiftedt
|
|
shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
|
|
|
|
printInfo :: RoomInt -> Int -> RoomInt -> IO ()
|
|
printInfo (parentrm,parenti) childn (childrm,childi) = do
|
|
putStr $ rpns 20 (_rmName childrm ++ "-" ++ show childi)
|
|
++ rpns 9 (" child " ++ show childn )
|
|
++ rpns 25 (" of " ++ _rmName parentrm ++ "-" ++ show parenti )
|
|
where
|
|
rpns x s = rightPadNoSquash x ' ' s
|
|
|
|
doLnkEff :: (Point2,Float) -> Room -> Room
|
|
doLnkEff x rm = case _rmLinkEff rm of
|
|
(eff:effs) -> eff x $ rm & rmLinkEff .~ effs
|
|
_ -> rm
|