--{-# LANGUAGE TupleSections #-}
module Dodge.Layout 
    ( generateLevelFromRoomList
    ) where
import Dodge.Data
import Dodge.Path
import Dodge.ShiftPoint
import Dodge.Placement.PlaceSpot
import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.LevelStructure
import Dodge.Room.Foreground
import Dodge.Wall.Zone
import Dodge.GameRoom
import Dodge.Bounds
import Dodge.Default.Wall
import Dodge.Room.Link
import Dodge.Randify
import Geometry
import Geometry.Vector3D
import Geometry.ConvexPoly
import qualified IntMapHelp as IM
import Tile
import Dodge.RandomHelp
import Color
import Shape
--import Padding

import Data.List (nubBy)
import Data.Traversable
import Control.Lens
import System.Random
import Data.Foldable
import qualified Control.Foldl as L
import Data.Maybe
import Data.Function
import Control.Monad.State

generateLevelFromRoomList :: IM.IntMap Room -> World -> World
generateLevelFromRoomList gr' w 
    = initWallZoning 
    . setupWorldBounds
    . placeWires
    . doAfterPlacements
    . doPartialPlacements
    . doExtendedPlacements
    . doIndividualPlacements
--    . flip (mapAccumR doRoomPlacements) (IM.elems rs')
    . worldToGenWorld rs'
    $ w { _walls        = wallsFromRooms rs
        , _floorTiles   = floorsFromRooms rs
        , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
        , _pathGraph    = path
        , _pathGraphP   = pairPath
        }
  where
    path = pairsToGraph dist pairPath
    pairPath = concatMap _rmPath rs
    rs = map doRoomShift $ IM.elems rs'
    rs'= mapM (shuffleRoomPos >=> addRandomTile) gr' & evalState $ _randGen w

addRandomTile :: RandomGen g => Room -> State g Room
addRandomTile r = do
    z <- state $ randomR (0,63)
    return $ addTile z r

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

placeWires :: GenWorld -> World
placeWires w = foldr placeRoomWires (_gWorld w) $ _gRooms w

placeRoomWires :: Room -> World -> World
placeRoomWires rm w = IM.foldr ($) w 
    $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)

placeWire :: Room -> RoomWire -> RoomWire -> World -> World
placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape 
    %~ (col ( thinHighBarChain h2 (map (shiftPointBy rs) doOrdering) 
            <> barPP 1.5 (addZ h1 p) (addZ h2 p)
            ) 
        <>
        )
  where
    --TODO use rmWalls for non convex rooms
    --rmWalls = foldr cutWalls [] (_rmPolys rm)
    doOrdering = orderPolygonAround rmcen (p:q:ps)
    col | clockwise = colorSH red
        | otherwise = colorSH red
    rmps = concat $ _rmPolys rm
    rmcen = centroid rmps
    clockwise = isLHS rmcen p q
    ps  | clockwise = filter leftprightq rmps
        | otherwise = filter rightpleftq rmps
    leftprightq x = isLHS rmcen p x && isRHS rmcen q x
    rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
    rs = _rmShift rm

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

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

doPartialPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld
doPartialPlacements (im,w) = let (gw,rms) = mapAccumR (doPartialPlacement im) w (_gRooms w)
    in gw {_gRooms = rms}

doPartialPlacement :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
doPartialPlacement im w rm = case _rmPartPmnt rm of
    Nothing -> (w, rm)
    Just fi -> case _rmTakeFrom rm of
        Nothing -> (w, rm)
        Just i  -> fst $ placeSpot (w,rm) (fi (im IM.! i))

doExtendedPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld)
doExtendedPlacements w = let ((pmnts,gw),rms) = mapAccumR doExtendedPlacement (IM.empty,w) (_gRooms w)
    in (pmnts,gw{_gRooms = rms})

doExtendedPlacement :: (IM.IntMap [Placement], GenWorld) -> Room 
    -> ( (IM.IntMap [Placement], GenWorld) , Room )
doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of
    Nothing -> ( (im,w) , rm )
    Just plmnt -> case _rmLabel rm of
        Nothing -> ( (im,w) , rm )
        Just i  -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt
            in ( (IM.insert i plmnts im, neww) , newrm )

doIndividualPlacements :: GenWorld -> GenWorld
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_gRooms gw)
    in gw' {_gRooms = rms}

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

setupWorldBounds :: World -> World
setupWorldBounds w = w
    & worldBounds . bdMinX .~ f minx
    & worldBounds . bdMaxX .~ f maxx
    & worldBounds . bdMinY .~ f miny
    & worldBounds . bdMaxY .~ f maxy
  where
    f = fromMaybe 0
    ps = IM.map (fst . _wlLine) $ _walls 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

--polyhedrasToEdges :: [Polyhedra] -> [Point3]
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges

initWallZoning :: World -> World
initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w)

--makePath :: Tree Room -> [(Point2,Point2)]
--makePath = concatMap _rmPath . flatten

wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms = --    divideWalls .
    IM.fromAscList 
    . 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)
--       ++ map fst (_rmLinks rm)
    , _grViewpointsEx = concatMap unpos (_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
        ]
    unpos (UsedOutLink _ _ p a) = doubleShift p a
    unpos (UsedInLink  _ p a) = doubleShift p a
    unpos _ = []
    undir (UsedOutLink _ _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
    undir (UsedInLink  _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
    undir _ = Nothing
    closePoints x y = roundPoint2 x == roundPoint2 y
    getDir (UsedInLink _ _ a:_) = a  + snd (_rmShift rm)
    getDir (_:xs) = getDir xs
    getDir _ = 0 -- fallback

floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)

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