Refactor, try to limit dependencies
This commit is contained in:
+107
-93
@@ -1,150 +1,164 @@
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- | 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.Data
|
||||
Creates a list of rooms; after this step the structure is determined by the actual positions of rooms.
|
||||
-}
|
||||
module Dodge.Tree.Shift (
|
||||
positionRoomsFromTree,
|
||||
PosRooms (..),
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Bifunctor
|
||||
import Data.List (delete)
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Set as S
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Room.Link
|
||||
import TreeHelp
|
||||
import Dodge.RoomLink
|
||||
import Geometry.ConvexPoly
|
||||
--import Geometry.Data
|
||||
import LensHelp hiding (Empty, (<|), (|>))
|
||||
import Padding
|
||||
import LensHelp hiding (Empty, (<|) , (|>))
|
||||
--import Control.Lens hiding (Empty, (<|) , (|>))
|
||||
import TreeHelp
|
||||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.List (delete)
|
||||
import Data.Bifunctor
|
||||
import Control.Lens
|
||||
|
||||
type RoomInt = (Room,Int)
|
||||
type RoomInt = (Room, Int)
|
||||
|
||||
data PosRooms = PosRooms
|
||||
{ _prBounds :: [ConvexPoly]
|
||||
, _prRooms :: [RoomInt]
|
||||
, _prRooms :: [RoomInt]
|
||||
}
|
||||
|
||||
makeLenses ''PosRooms
|
||||
|
||||
|
||||
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe PosRooms)
|
||||
positionRoomsFromTree (Node (r,i) ts) = printColumnTitles
|
||||
>> fmap (fmap (prRooms %~ map (first createUnusedLinkPos)))
|
||||
(posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r',i) (zipCount ts) Empty)
|
||||
positionRoomsFromTree (Node (r, i) ts) =
|
||||
printColumnTitles
|
||||
>> fmap
|
||||
(fmap (prRooms %~ map (first createUnusedLinkPos)))
|
||||
(posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r', i) (zipCount ts) Empty)
|
||||
where
|
||||
r' = r & rmMID ?~ 0
|
||||
|
||||
posRms :: PosRooms
|
||||
-> RoomInt
|
||||
-> [(Int,Tree RoomInt)] -- the list of children, with indices
|
||||
-> Seq.Seq (Tree RoomInt)
|
||||
-> IO (Maybe PosRooms)
|
||||
posRms ::
|
||||
PosRooms ->
|
||||
RoomInt ->
|
||||
[(Int, Tree RoomInt)] -> -- the list of children, with indices
|
||||
Seq.Seq (Tree RoomInt) ->
|
||||
IO (Maybe PosRooms)
|
||||
posRms prs roomi [] st = case st of
|
||||
Empty -> return $ Just $ prs & prRooms .:~ roomi
|
||||
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
|
||||
posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
|
||||
printInfoCheckNum parenti numChild childi
|
||||
tryParentLinks outlinks
|
||||
where
|
||||
child = fst childi
|
||||
outlinks = zipCount
|
||||
. Prelude.filter (_rmConnectsTo child . _rlType)
|
||||
$ _rmLinks parent
|
||||
outlinks =
|
||||
zipCount
|
||||
. Prelude.filter (_rmConnectsTo child . _rlType)
|
||||
$ _rmLinks parent
|
||||
tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
|
||||
tryParentLinks ((j,outlnk):ls) = tryChildLinks . zipCount . rmInLinks $ fst childi
|
||||
tryParentLinks ((j, outlnk) : ls) = tryChildLinks . zipCount . rmInLinks $ fst childi
|
||||
where
|
||||
tryChildLinks [] = tryParentLinks ls
|
||||
tryChildLinks ((numinlink,il):ils)
|
||||
| clipping = tryChildLinks ils
|
||||
tryChildLinks ((numinlink, il) : ils)
|
||||
| clipping = tryChildLinks ils
|
||||
| otherwise = do
|
||||
putStrLn $ show j ++ "-" ++ show numinlink
|
||||
mayrs <- posRms
|
||||
(prs & prBounds .++~ newBounds)
|
||||
(first updateparent parenti)
|
||||
its
|
||||
(tseq |> shiftedt)
|
||||
mayrs <-
|
||||
posRms
|
||||
(prs & prBounds .++~ newBounds)
|
||||
(first updateparent parenti)
|
||||
its
|
||||
(tseq |> shiftedt)
|
||||
case mayrs of
|
||||
Just rms -> return $ Just rms
|
||||
Nothing -> printInfo parenti numChild childi
|
||||
>> tryChildLinks ils
|
||||
Nothing ->
|
||||
printInfo parenti numChild childi
|
||||
>> tryChildLinks ils
|
||||
where
|
||||
newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
|
||||
clipping = or (convexPolysOverlap <$> newBounds <*> _prBounds prs)
|
||||
updateparent rm = _rmLinkEff rm il child numChild outlnk rm
|
||||
& rmLinks %~ delete outlnk
|
||||
& rmPos .:~ RoomPos
|
||||
{ _rpPos = fst (lnkPosDir outlnk)
|
||||
, _rpDir = snd (lnkPosDir outlnk)
|
||||
, _rpType = S.empty
|
||||
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
|
||||
, _rpPlacementUse = 0
|
||||
}
|
||||
& rmChildren .:~ snd childi
|
||||
updateparent rm =
|
||||
_rmLinkEff rm il child numChild outlnk rm
|
||||
& rmLinks %~ delete outlnk
|
||||
& rmPos
|
||||
.:~ RoomPos
|
||||
{ _rpPos = fst (lnkPosDir outlnk)
|
||||
, _rpDir = snd (lnkPosDir outlnk)
|
||||
, _rpType = S.empty
|
||||
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
|
||||
, _rpPlacementUse = 0
|
||||
}
|
||||
& rmChildren .:~ snd childi
|
||||
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
|
||||
updatechild rm = rm
|
||||
& rmMParent ?~ snd parenti
|
||||
& rmMID ?~ snd childi
|
||||
& rmLinks %~ delete il
|
||||
& rmPos .:~ RoomPos
|
||||
{ _rpPos = fst (lnkPosDir il)
|
||||
, _rpDir = snd (lnkPosDir il)
|
||||
, _rpType = S.empty
|
||||
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
|
||||
, _rpPlacementUse = 0
|
||||
}
|
||||
shiftedt = over root
|
||||
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
|
||||
t
|
||||
updatechild rm =
|
||||
rm
|
||||
& rmMParent ?~ snd parenti
|
||||
& rmMID ?~ snd childi
|
||||
& rmLinks %~ delete il
|
||||
& rmPos
|
||||
.:~ RoomPos
|
||||
{ _rpPos = fst (lnkPosDir il)
|
||||
, _rpDir = snd (lnkPosDir il)
|
||||
, _rpType = S.empty
|
||||
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
|
||||
, _rpPlacementUse = 0
|
||||
}
|
||||
shiftedt =
|
||||
over
|
||||
root
|
||||
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
|
||||
t
|
||||
|
||||
createUnusedLinkPos :: Room -> Room
|
||||
createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
|
||||
where
|
||||
f rl = RoomPos
|
||||
{ _rpPos = _rlPos rl
|
||||
, _rpDir = _rlDir rl
|
||||
, _rpType = S.empty
|
||||
, _rpLinkStatus = UnusedLink $ _rlType rl
|
||||
, _rpPlacementUse = 0
|
||||
}
|
||||
f rl =
|
||||
RoomPos
|
||||
{ _rpPos = _rlPos rl
|
||||
, _rpDir = _rlDir rl
|
||||
, _rpType = S.empty
|
||||
, _rpLinkStatus = UnusedLink $ _rlType rl
|
||||
, _rpPlacementUse = 0
|
||||
}
|
||||
|
||||
zipCount :: [a] -> [(Int,a)]
|
||||
zipCount = Prelude.zip [0..]
|
||||
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 (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]
|
||||
theColumns = printColumns [20, 5, 20, 20]
|
||||
|
||||
printColumnTitles :: IO ()
|
||||
printColumnTitles = theColumns ["Parent","Cnum","Child","Link pair"]
|
||||
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
|
||||
]
|
||||
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
|
||||
]
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user