loop/src/Dodge/Tree/Shift.hs

{- | 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
import Dodge.Room.Link
import TreeHelp
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 qualified Data.Sequence as Seq
import Data.List (delete)
import Data.Bifunctor
import Control.Lens

type RoomInt = (Room,Int)

data PosRooms = PosRooms
    { _prBounds :: [ConvexPoly]
    , _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)
  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 prs roomi [] st = case st of
    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
    printInfoCheckNum parenti numChild childi
    tryParentLinks outlinks
  where
    child = fst childi
    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
      where
        tryChildLinks [] = tryParentLinks ls
        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)
                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 <*> _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
            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

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
        }

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 :: RoomLink -> Room -> Room
--doLnkEff x rm = case _rmLinkEff rm of
--    (eff:effs) -> eff x $ rm & rmLinkEff .~ effs
--    _ -> rm