{-# LANGUAGE TupleSections #-}

module Dodge.Layout (
    generateLevelFromRoomList,
    tilesFromRooms,
    shuffleRoomPos,
) where

import Control.Monad
-- import Dodge.Path.Translate
import qualified Control.Foldl as L
import Control.Lens
import Data.Foldable
import Data.Function
import Linear
-- import Data.Graph.Inductive (labEdges, labNodes)
import Data.List (nubBy, sortOn)
import Data.Maybe
import Data.Tile
import qualified Data.Vector.Unboxed as UV
-- 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.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
        . doInPlacements
        . doIndividualPlacements
        . setTiles
        . worldToGenWorld rs'
        $ w
            & cWorld . lWorld . walls .~ wallsFromRooms rs
            & cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
            & cWorld . incNode .~ inodes
            & cWorld . incGraph .~ igraph
            & cWorld . incEdges .~ ipairs
            & incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i, p) m) mempty inodes
            & incEdgeZoning .~ foldl' (flip (zoneIncPe inodes)) mempty ipairs
  where
    pairs = snapToGrid $ foldMap _rmPath rs
    (inodes, igraph, ipairs) = pairsToIncGraph pairs
    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

roomTileZeroShift :: Room -> Point2A
roomTileZeroShift rm = fromMaybe (rm ^. rmShift) 
    $ rm ^? rmFloor . tiles . ix 0 . tileZeroShift . _Just

setTile :: Room -> GenWorld -> GenWorld
setTile r gw = case _rmFloor r of
    Tiled xs -> fromMaybe gw $ do
        pid <- r ^. rmMParent
        rm <- gw ^? genRooms . ix pid
        guard $ rm ^? rmFloor . tiles . ix 0 . tileArrayZ == xs ^? ix 0 . tileArrayZ
        return $ gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor . tiles . ix 0 . tileZeroShift 
            ?~ roomTileZeroShift rm
    InheritFloor ->
        gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
  where
    t = fromMaybe (Tile poly (V2 0 0) (V2 1 0) 16 Nothing) $ do
            pid <- r ^. rmMParent
            rm <- gw ^? genRooms . ix pid
            (rm ^? rmFloor . tiles . ix 0)
                <&> tileZeroShift ?~ roomTileZeroShift rm
    poly =
        orderPolygon
            . convexHullSafe
            . nubBy ((==) `on` roundPoint2)
            . concat
            $ _rmPolys r

shuffleRoomPos :: (RandomGen g) => Room -> State g Room
shuffleRoomPos = rmPos shuffle

doInPlacements :: GenWorld -> GenWorld
doInPlacements w =
    foldl' (\gw (i, (_, f)) -> rplaceSpot i gw (f gw)) w
        . sortOn (fst . snd)
        . foldMap g
        $ w ^. genRooms
  where
    g rm = (rm ^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
    rplaceSpot i gw rx = placeSpot i (gw & gwWorld . randGen .~ gen) x
      where
        (x,gen) = runState rx (gw ^. gwWorld . randGen)

doIndividualPlacements :: GenWorld -> GenWorld
doIndividualPlacements gw = foldl' doRoomPlacements gw (_genRooms gw)

doRoomPlacements :: GenWorld -> Room -> GenWorld
doRoomPlacements w rm =
    foldl' (placeSpot i) (w & genRooms . ix i . rmPmnts .~ mempty)
        . sortOn plPriority
        $ _rmPmnts rm
  where
    i = rm ^?! rmMID . _Just

plPriority :: Placement -> Int
plPriority pl = case pl ^. plType of
    PutChasm{} -> 0
    PutBlock{} -> 1
    PutDoor{} -> 2
    _ -> 3

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
        , _grRmBounds = map (map doshift) $ _rmBound 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 _rpType rp of
        UnusedLink{} -> Just $ _rpPos rp
        _ -> Nothing
    filterUsedLinks rp = case _rpType rp of
        UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
        UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
        _ -> []
    undir rp = case _rpType 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 _rpType 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