98 lines
3.9 KiB
Haskell
98 lines
3.9 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 Dodge.RoomLink
|
|
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) = printHeader
|
|
>> posRms (map pointsToPoly $ _rmBound r) (r,i) (zipCount ts) Empty
|
|
|
|
posRms :: [ConvexPoly]
|
|
-> RoomInt
|
|
-> [(Int,Tree RoomInt)] -- the list of children, with indices
|
|
-> Seq (Tree RoomInt)
|
|
-> IO (Maybe [Room])
|
|
posRms bounds (parent,_) [] st = case st of
|
|
Empty -> return $ Just [parent]
|
|
Node childi ts :<| tseq -> fmap (parent:) <$> posRms bounds childi (zipCount ts) tseq
|
|
posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
|
|
printInfoCheckNum parenti numChild childi
|
|
tryParentLinks $ zipCount $ rmOutLinks parent
|
|
where
|
|
tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
|
|
tryParentLinks ((j,outlnk):ls) = tryChildLinks $ zipCount (rmInLinks $ fst childi)
|
|
where
|
|
tryChildLinks [] = tryParentLinks ls
|
|
tryChildLinks ((numinlink,il):ils)
|
|
| clipping = tryChildLinks ils
|
|
| otherwise = do
|
|
putStrLn $ show j ++ "-"++show numinlink
|
|
mayrs <- posRms (convexBounds ++ 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)
|
|
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
|
|
& rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir outlnk) :)
|
|
l' = 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
|
|
|
|
zipCount :: [a] -> [(Int,a)]
|
|
zipCount = Prelude.zip [0..]
|
|
|
|
printColumns :: [Int] -> [String] -> IO ()
|
|
printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs
|
|
printColumns _ strs = putStrLn $ concat strs
|
|
|
|
theColumns :: [String] -> IO ()
|
|
theColumns = printColumns [20,5,20,20]
|
|
|
|
printHeader :: IO ()
|
|
printHeader = theColumns ["Parent","Cnum","Child","Link pair"]
|
|
|
|
printInfo :: RoomInt -> Int -> RoomInt -> IO ()
|
|
printInfo (parentrm,parenti) childn (childrm,childi) = do
|
|
putStr $ rpns 20 (_rmName parentrm ++ "-" ++ show parenti )
|
|
++ rpns 5 (show childn ++ " ")
|
|
++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
|
|
where
|
|
rpns x s = rightPadNoSquash x ' ' s
|
|
printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO ()
|
|
printInfoCheckNum p 0 c = printInfo p 0 c
|
|
printInfoCheckNum _ childn (childrm,childi) = do
|
|
putStr $ rpns 20 ("")
|
|
++ rpns 5 (show childn ++ " ")
|
|
++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
|
|
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
|