--{-# LANGUAGE TupleSections #-}
module Dodge.Layout 
    ( generateLevelFromRoomList
    ) where
import Data.Tile
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.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 -> GenWorld
generateLevelFromRoomList gr' w = over gWorld initWallZoning 
    . over gWorld randomCompass
    . over gWorld setupWorldBounds
    . placeWires
    . doAfterPlacements
    . doInPlacements
    . doOutPlacements
    . doIndividualPlacements
    . setFloors
    . worldToGenWorld rs'
    $ w { _walls        = wallsFromRooms 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 gr' & evalState $ _randGen w

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

putFloorTiles :: GenWorld -> GenWorld
putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw

setFloors :: GenWorld -> GenWorld
setFloors = putFloorTiles . setTiles

-- 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 $ _gWorld gw

setTile :: Room -> GenWorld -> GenWorld
setTile r gw = case _rmFloor r of
    Tiled {} -> gw
    InheritFloor -> gw & gWorld . 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 (_gWorld 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

placeWires :: GenWorld -> GenWorld
placeWires w = w
    & gWorld .~ foldr placeRoomWires (_gWorld w) (_genRooms $ _gWorld 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 (_genPlacements $ _gWorld gw)

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

doInPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld
doInPlacements (im,w) = 
    let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms $ _gWorld w)
    in gw & gWorld . 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 $ _gWorld w)
    in (pmnts,gw & gWorld . 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 $ _gWorld gw)
    in gw' & gWorld . 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 & worldBounds %~
    ( (bdMinX .~ f minx)
    . (bdMaxX .~ f maxx)
    . (bdMinY .~ f miny)
    . (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)
        ++ 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

floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)

floorsFromGenWorld :: GenWorld -> [(Point3,Point3)]
floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms . _gWorld

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