loop/src/Dodge/Layout.hs

--{-# LANGUAGE TupleSections #-}
module Dodge.Layout (
    generateLevelFromRoomList,
    tilesFromRooms,
) where

import Dodge.Path.Translate
import qualified Control.Foldl as L
import Control.Lens
import Data.Foldable
import Data.Function
import Data.Graph.Inductive (labEdges, labNodes)
import Data.List (nubBy)
import Data.Maybe
import Data.Tile
import Data.Traversable
import Dodge.Data.GenWorld
import Dodge.Default.Wall
import Dodge.GameRoom
--import Dodge.Item.Location.Initialize
import Dodge.LevelGen.LevelStructure
import Dodge.LevelGen.StaticWalls
import Dodge.Path
import Dodge.Placement.PlaceSpot
import Dodge.Randify
import Dodge.Room.Link
import Dodge.ShiftPoint
import Dodge.Wall.Zone
import Dodge.Zoning.Pathing
import Geometry
import qualified IntMapHelp as IM
import RandomHelp

generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld
generateLevelFromRoomList gr' w =
    over gwWorld initWallZoning
        . over gwWorld randomCompass
        . over gwWorld setupWorldBounds
--        . over (gwWorld . cWorld . lWorld) initItemLocations
        . doAfterPlacements
        . doInPlacements
        . doOutPlacements
        . doIndividualPlacements
        . setTiles
        . worldToGenWorld rs'
        $ w & cWorld . lWorld . walls .~ wallsFromRooms rs
            & cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
            & cWorld . pathGraph .~ path
            & pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
            & peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
  where
    (_, path) = pairsToGraph pairPath'
    pairPath = foldMap _rmPath rs
    pairPath' = fusePairs pairPath
    rs = map doRoomShift $ IM.elems rs'
    rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w


randomCompass :: World -> World
randomCompass w = w & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)

-- note the order of traversal of the rooms is important
-- hence the reverse
-- this is not ideal: should do this in some more sensible way
setTiles :: GenWorld -> GenWorld
setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw

setTile :: Room -> GenWorld -> GenWorld
setTile r gw = case _rmFloor r of
    Tiled{} -> gw
    InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
  where
    t = case _rmMParent r of
        Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
        Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r

shuffleRoomPos :: RandomGen g => Room -> State g Room
shuffleRoomPos rm = do
    newPos <- shuffle $ _rmPos rm
    return $ rm & rmPos .~ newPos

doAfterPlacements :: GenWorld -> GenWorld
doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)

doAfterPlacement :: [(Placement, Int)] -> GenWorld -> GenWorld
doAfterPlacement pmntis gw = gRandify gw $ do
    (pmnt, i) <- takeOne pmntis
    let (newgw, rm) = fst $ placeSpot (gw, _genRooms gw IM.! i) pmnt
    return $ newgw & genRooms . ix i .~ rm

doInPlacements :: (IM.IntMap [Placement], GenWorld) -> GenWorld
doInPlacements (im, w) =
    let (gw, rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
     in gw & genRooms .~ rms

doRoomInPlacements :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
doRoomInPlacements im w rm = foldr f (w, rm) $ _rmInPmnt rm
  where
    f (InPlacement plf i) (w', r') = fst $ placeSpot (w', r') (plf (w' ^. gwWorld) $ im IM.! i)

doOutPlacements :: GenWorld -> (IM.IntMap [Placement], GenWorld)
doOutPlacements w =
    let ((pmnts, gw), rms) = mapAccumR doRoomOutPlacements (IM.empty, w) (_genRooms w)
     in (pmnts, gw & genRooms .~ rms)

doRoomOutPlacements ::
    (IM.IntMap [Placement], GenWorld) ->
    Room ->
    ((IM.IntMap [Placement], GenWorld), Room)
doRoomOutPlacements imw r = foldr f (imw, r) $ IM.toList $ _rmOutPmnt r
  where
    f (i, pl) ((im, w), rm) =
        let ((neww, newrm), plmnts) = placeSpot (w, rm) pl
         in ((IM.insert i plmnts im, neww), newrm)

doIndividualPlacements :: GenWorld -> GenWorld
doIndividualPlacements gw =
    let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw)
     in gw' & genRooms .~ rms

doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room)
doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w, rm) $ _rmPmnts rm

setupWorldBounds :: World -> World
setupWorldBounds w =
    w & cWorld . cwGen . cwgWorldBounds
        %~ ( (bdMinX .~ f minx)
                . (bdMaxX .~ f maxx)
                . (bdMinY .~ f miny)
                . (bdMaxY .~ f maxy)
           )
  where
    f = fromMaybe 0
    ps = IM.map (fst . _wlLine) $ w ^. cWorld . lWorld . walls -- _walls (_cWorld w)
    (minx, maxx, miny, maxy) =
        L.fold
            ( (,,,)
                <$> L.premap fstV2 L.minimum
                <*> L.premap fstV2 L.maximum
                <*> L.premap sndV2 L.minimum
                <*> L.premap sndV2 L.maximum
            )
            ps

wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms =
    --    divideWalls .
    IM.fromDistinctAscList
        . zipWith f [0 ..]
        . removeInverseWalls
        . foldl' (flip cutWalls) []
        . concatMap _rmPolys
  where
    f i (x, y) = (i, defaultWall{_wlLine = (x, y), _wlID = i})

-- TODO sort out shifting before or after etc
gameRoomsFromRooms :: [Room] -> [GameRoom]
gameRoomsFromRooms = fmap gameRoomFromRoom

gameRoomFromRoom :: Room -> GameRoom
gameRoomFromRoom rm =
    GameRoom
        { _grViewpoints =
            map doshift $
                _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
                    ++ mapMaybe filterUnusedLinks (_rmPos rm)
        , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
        , _grBound =
            map doshift $
                expandPolyCorners 50 . convexHullSafe . nubBy closePoints
                    . concat
                    $ _rmBound rm ++ _rmPolys rm
        , _grDir = getDir $ _rmPos rm
        , _grLinkDirs = mapMaybe undir $ _rmPos rm
        , _grName = _rmName rm
        }
  where
    doshift = shiftPointBy (_rmShift rm)
    doubleShift p a =
        map
            doshift
            [ p +.+ 10 *.* unitVectorAtAngle a
            , p -.- 10 *.* unitVectorAtAngle a
            ]
    filterUnusedLinks rp = case _rpLinkStatus rp of
        UnusedLink{} -> Just $ _rpPos rp
        _ -> Nothing
    filterUsedLinks rp = case _rpLinkStatus rp of
        UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
        UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
        _ -> []
    undir rp = case _rpLinkStatus rp of
        UsedOutLink{} -> ma
        UsedInLink{} -> ma
        _ -> Nothing
      where
        ma = Just $ 0.5 * pi + _rpDir rp + snd (_rmShift rm)
    closePoints x y = roundPoint2 x == roundPoint2 y
    getDir (rp : xs) = case _rpLinkStatus rp of
        UsedInLink{} -> _rpDir rp + snd (_rmShift rm)
        _ -> getDir xs
    getDir _ = 0 -- fallback

tilesFromRooms :: [Room] -> [Tile]
tilesFromRooms = concatMap (getTiles . _rmFloor . doRoomShift)

getTiles :: Floor -> [Tile]
getTiles fl = case fl of
    Tiled xs -> xs
    _ -> error "tiles not correctly set for some room"

--divideWall :: Wall -> [Wall]
--divideWall wl
--    = let (a,b) = _wlLine wl
--          ps = divideLine (zoneSize * 2) a b
--      in  zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)

--divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
--divideWallIn wl wls =
--    let (wl':newWls) = divideWall wl
--        k = IM.newKey wls
--        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
--    in  foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
--
--divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
--divideWalls wls = foldl' (flip divideWallIn) wls wls

--insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
--insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
--    where f _ = IM.insert y obj

--shiftRoomTree :: Tree Room -> Tree Room
--shiftRoomTree (Node t []) = Node t []
--shiftRoomTree (Node t ts) = Node t
--    $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
--    (_rmLinks t)
--    ts

--shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
--shiftRoomTreeConstruction (Node t []) = [Node t []]
--shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
--    zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
--    (_rmLinks t)
--    ts
--  where
--    f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a)  r
--      where
--        (p,a) = last $ _rmLinks r

--addTile :: Float -> Room -> Room
--addTile z r
--    | not (null (_rmFloor r)) || null rp = r
--    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
--  where
--    rp = _rmPolys r
--    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp