--{-# 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 $ 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) $ _rmOutPmnt r
  where
    f (OutPlacement pl i) ((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