142 lines
5.2 KiB
Haskell
142 lines
5.2 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 LensHelp hiding (Empty, (<|) , (|>))
|
|
--import Control.Lens hiding (Empty, (<|) , (|>))
|
|
|
|
import qualified Data.Set as S
|
|
import Data.Tree
|
|
import Data.Sequence hiding (zipWith)
|
|
import Data.List (delete)
|
|
import Data.Bifunctor
|
|
|
|
type RoomInt = (Room,Int)
|
|
|
|
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
|
|
positionRoomsFromTree (Node (r,i) ts) = printColumnTitles
|
|
>> fmap (fmap (map $ first createUnusedLinkPos))
|
|
(posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty)
|
|
where
|
|
r' = r & rmMID ?~ 0
|
|
|
|
posRms :: [ConvexPoly]
|
|
-> RoomInt
|
|
-> [(Int,Tree RoomInt)] -- the list of children, with indices
|
|
-> Seq (Tree RoomInt)
|
|
-> IO (Maybe [RoomInt])
|
|
posRms bounds (parent,i) [] st = case st of
|
|
Empty -> return $ Just [(parent,i)]
|
|
Node childi ts :<| tseq -> fmap ((parent,i):) <$> posRms bounds childi (zipCount ts) tseq
|
|
posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
|
|
printInfoCheckNum parenti numChild childi
|
|
tryParentLinks outlinks
|
|
where
|
|
child = fst childi
|
|
outlinks = zipCount
|
|
. Prelude.filter (not . S.null . S.intersection (_rmConnectsTo child) . _rlType)
|
|
$ _rmLinks parent
|
|
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
|
|
(newBounds ++ bounds)
|
|
(first updateparent parenti)
|
|
its
|
|
(tseq |> shiftedt)
|
|
case mayrs of
|
|
Just rms -> return $ Just rms
|
|
Nothing -> printInfo parenti numChild childi
|
|
>> tryChildLinks ils
|
|
where
|
|
newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
|
|
clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
|
|
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
|
|
& rmLinks %~ delete outlnk
|
|
& rmPos .:~ UsedOutLink
|
|
{ _rpChildNum = numChild
|
|
, _rpOutRoomID = snd childi
|
|
, _rpPos = fst (lnkPosDir outlnk)
|
|
, _rpDir = snd (lnkPosDir outlnk)
|
|
, _rpLinkType = _rlType outlnk
|
|
}
|
|
& rmChildren .:~ snd childi
|
|
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
|
|
updatechild rm = rm
|
|
& rmMParent ?~ snd parenti
|
|
& rmMID ?~ snd childi
|
|
& rmLinks %~ delete il
|
|
& rmPos .:~ UsedInLink
|
|
{ _rpInRoomID = 0
|
|
, _rpPos = fst (lnkPosDir il)
|
|
, _rpDir = snd (lnkPosDir il)
|
|
, _rpLinkType = _rlType il
|
|
}
|
|
shiftedt = applyToRoot
|
|
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
|
|
t
|
|
|
|
createUnusedLinkPos :: Room -> Room
|
|
createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
|
|
where
|
|
f rl = UnusedLink
|
|
{ _rpPos = _rlPos rl
|
|
, _rpDir = _rlDir rl
|
|
, _rpLinkType = _rlType rl
|
|
}
|
|
|
|
zipCount :: [a] -> [(Int,a)]
|
|
zipCount = Prelude.zip [0..]
|
|
|
|
printColumns :: [Int] -> [String] -> IO ()
|
|
printColumns is ss = printPartialColumns is ss >> putStrLn ""
|
|
|
|
printPartialColumns :: [Int] -> [String] -> IO ()
|
|
printPartialColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printPartialColumns is strs
|
|
printPartialColumns _ strs = putStr $ concat strs
|
|
|
|
theColumns :: [String] -> IO ()
|
|
theColumns = printColumns [20,5,20,20]
|
|
|
|
printColumnTitles :: IO ()
|
|
printColumnTitles = theColumns ["Parent","Cnum","Child","Link pair"]
|
|
|
|
printInfo :: (Show a) => RoomInt -> a -> RoomInt -> IO ()
|
|
printInfo (parentrm,parenti) childn (childrm,childi) = printPartialColumns
|
|
[20,5,20]
|
|
[_rmName parentrm ++ "-" ++ show parenti
|
|
,show childn ++ " "
|
|
,_rmName childrm ++ "-" ++ show childi
|
|
]
|
|
|
|
printInfoCheckNum :: (Show a, Eq a, Num a) => RoomInt -> a -> RoomInt -> IO ()
|
|
printInfoCheckNum (parentrm,parenti) childn (childrm,childi) = printPartialColumns
|
|
[20,5,20]
|
|
[rname
|
|
,show childn
|
|
,_rmName childrm ++ "-" ++ show childi
|
|
]
|
|
where
|
|
rname = case childn of
|
|
0 -> _rmName parentrm ++ "-" ++ show parenti
|
|
_ -> ""
|
|
|
|
doLnkEff :: (Point2,Float) -> Room -> Room
|
|
doLnkEff x rm = case _rmLinkEff rm of
|
|
(eff:effs) -> eff x $ rm & rmLinkEff .~ effs
|
|
_ -> rm
|