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

import qualified Data.Vector.Unboxed as UV
--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,sortOn)
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.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
        . doInPlacements
--        . doOutPlacements
        . 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

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

doInPlacements :: GenWorld -> GenWorld
doInPlacements w = foldl' (\gw (i,(_,f)) -> placeSpot i gw (f gw)) w
    . sortOn (fst.snd)
    $ foldMap g $ w ^. genRooms
  where
    g rm = (rm^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
--    let (gw, rms) = mapAccumR doRoomInPlacements w (_genRooms w)
--     in gw & genRooms .~ rms

--doRoomInPlacements :: GenWorld -> Room -> (GenWorld, Room)
--doRoomInPlacements w rm = foldr f (w, rm) $ _rmInPmnt rm
--  where
--    f plf (w', r') =  placeSpot (w', r') (plf w')

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) 
    $ _rmPmnts rm
  where
    i = rm ^?! rmMID . _Just

--placeSpot' :: Int -> GenWorld -> Placement -> GenWorld
--placeSpot' = placeSpot
--placeSpot' i gw x = 
--    let (gw',r') = placeSpot (gw,(gw ^?! genRooms . ix i)) x
--    in gw' & genRooms . ix i .~ r'

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 _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