65 lines
2.5 KiB
Haskell
65 lines
2.5 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 []
|
|
Node childi ts :<| tseq
|
|
-> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq
|
|
posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do
|
|
putStr $ (rpns 20 (_rmName cr ++ "-" ++ show i'))
|
|
++ (rpns 9 (" child " ++ show numChild ))
|
|
++ (rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i ))
|
|
tryLinks (0::Int) (_rmLinks parent)
|
|
where
|
|
rpns x s = rightPadNoSquash x ' ' s
|
|
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 -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> 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 (OutLink numChild) l :)
|
|
l' = shiftLinkBy (_rmShift parent) l
|
|
r' = doRoomShift . fst $ rootLabel shiftedt
|
|
shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
|
|
|
|
doLnkEff :: (Point2,Float) -> Room -> Room
|
|
doLnkEff x rm = case _rmLinkEff rm of
|
|
(eff:effs) -> eff x $ rm & rmLinkEff .~ effs
|
|
_ -> rm
|