loop/src/Dodge/Tree/Shift.hs

{-# 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.
-}
module Dodge.Tree.Shift (
    positionRoomsFromTree,
    PosRooms (..),
) where

--import Data.Monoid
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 Dodge.RoomLink
import Geometry.ConvexPoly
import LensHelp hiding (Empty, (<|), (|>))
import Padding
import TreeHelp

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 ?~ i

-- implement a heuristic for "better" room links?
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)
--            | Just xs <- clipping' = do
--                putStrLn $ show xs
--                tryChildLinks 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)
--            clipping' = getFirst . foldMap First $ convexPolysOverlapWitness <$> 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)
                            { _rpPos = outlnk ^. rlPos
                            , _rpDir = outlnk ^. rlDir
                            , _rpFlags = S.empty
                            , _rpType = UsedOutLink (_rlType outlnk) numChild (snd childi)
                            , _rpPlacementUse = mempty
                            }
                    & 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 outlnk)
                            --, _rpDir = snd (lnkPosDir outlnk)
                            { _rpPos = il ^. rlPos
                            , _rpDir = il ^. rlDir
                            , _rpFlags = mempty
                            , _rpType = UsedInLink (_rlType il) (snd parenti)
                            , _rpPlacementUse = mempty
                            }
            shiftedt =
                over
                    root
                    (first $ updatechild . shiftRoomShiftToLink 
                        (shiftedoutlink ^. rlPos, shiftedoutlink ^. rlDir) 
                        (il ^. rlPos, il ^. rlDir))
                    t

createUnusedLinkPos :: Room -> Room
createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
  where
    f rl =
        RoomPos
            { _rpPos = _rlPos rl
            , _rpDir = _rlDir rl
            , _rpFlags = mempty
            , _rpType = UnusedLink $ _rlType rl
            , _rpPlacementUse = mempty
            }

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