{-# LANGUAGE FlexibleInstances #-}
-- | deals with placement of objects within the world
-- after they have had their coordinates set by the layout
module Dodge.LevelGen 
    ( module Dodge.LevelGen
    , cutWalls
    , pairsToGraph
    , makeButton
    , makeSwitch
    ) where
import Dodge.Data
--import Dodge.Room.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.LineBlock
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.AutoDoor
import Dodge.LevelGen.TriggerDoor
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Data
import Geometry
import Geometry.Data
import Picture
import Polyhedra
import qualified IntMapHelp as IM

--import System.Random
import Control.Monad.State
--import Control.Applicative
import Control.Lens
import Data.List.Extra
--import Data.Function
--import Data.Maybe
--import qualified Data.Set as S
--import qualified Data.Map as M

placeSpots :: [Placement] -> World -> World
placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements
  where
    (singlePlacements, groupedPlacements) = partition isSPS pss
    isSPS SinglePlacement{} = True
    isSPS _ = False
    gplmnts :: [[Placement]]
    gplmnts = groupOn _groupPlacementID $ sortOn _groupPlacementID groupedPlacements
    w' = foldr putGroup w gplmnts
    putGroup :: [Placement] -> World -> World
    putGroup gps w'' = (_groupUpdate $ head gps) w'' gps

{- | OK, this is perhaps slightly impenetrable.
 - The idea is that for a list of collected group placements, we first update
 - the world for each placement and update the placements into PSTypes.
 - This is the mapAccumR step.
 - After this, for each placement we apply the group placement function to
 - the psType using a zipWith, and taking all the pstypes as a paramenter,
 - then successively update the world using a foldr. -}
--updateGroup :: [Placement] -> World -> World
--updateGroup ps w =
--    let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps
--        fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes
--    in foldr ($) w' fs
--{- | -}
--updateSpot :: World -> PlacementSpot -> (World, PSType)
--updateSpot w ps = case _psType ps of
--    PutButton bt -> undefined
--    PutCrit cr -> placeUpdateCr cr p rot w
--  where
--    p = _psPos ps
--    rot = _psRot ps
{- | -}    
placeSpot :: PlacementSpot -> World -> World
placeSpot ps w = case _psType ps of
    PutButton bt -> placeBt bt p rot w
    PutFlIt itm -> placeFlIt itm p rot w
    PutCrit cr -> placeCr cr p rot w
    PutLS ls dec -> placeLS ls dec p' rot w
    PutPressPlate pp -> placePressPlate pp p rot w
    RandPS rgen -> placeSpot (set psType evaluatedType ps) (set randGen g w)
      where 
        (evaluatedType, g) = runState rgen (_randGen w)
    PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
      where 
        mapBoth fn (x,y) = (fn x, fn y) 
    PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
    PutBlock{} -> error "messed up block placement somehow"
    PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) 
                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PutLineBlock wl width depth a b
        -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
    PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
      where 
        (q:qs) = map (shiftPointBy (p,rot)) ps'
        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
    PutForeground poly -> w & foregroundDecorations %~ (map (uncurry translateXY p . rotateXY rot) poly ++)
    PutNothing -> w
    PutID _ -> w
    --_   -> w
  where 
    p@(px,py) = _psPos ps
    p' = (px,py,0)
    rot = _psRot ps

-- TODO: remove this typeclass
class Shiftable a where
    translateS :: Point2 -> a -> a
    rotateS    :: Float -> a -> a

instance {-# OVERLAPPING #-} Shiftable Point2 where
    translateS = (+.+)
    rotateS    = rotateV

instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
    translateS p (x,y) = (translateS p x,translateS p y)
    rotateS    r (x,y) = (   rotateS r x,   rotateS r y)

instance (Shiftable a) => Shiftable [a] where
    translateS p x = map (translateS p) x
    rotateS    r x = map (rotateS r)    x

instance Shiftable PlacementSpot where
    translateS p' (PS p r x) = PS (p +.+ p') r x
    rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x

shiftPointBy :: (Point2,Float) -> Point2 -> Point2
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p

addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
addWalls qs wl wls = foldr (addPane wl) wls pairs
  where 
    (p:ps) = orderPolygon qs
    pairs = zip (ps ++ [p]) (p:ps)

addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
    { _wlLine = (p0,p1)
    , _wlID = IM.newKey wls
    })
    wls

placeBt 
    :: Button
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> World
placeBt bt p rot = over buttons addBT
  where 
    addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
{- Creates a floor item at a given point.
Assigns an id correctly.  -}
placeFlIt
    :: Item
    -> Point2   -- ^ Position
    -> Float    -- ^ Rotation
    -> World
    -> World
placeFlIt itm p rot = floorItems %~ 
    \ fis -> IM.insert (IM.newKey fis) 
        (FlIt
            { _flItPos = p
            , _flItRot = rot
            , _flItID = IM.newKey fis
            , _flIt = itm
            }
        ) fis

placePressPlate
    :: PressPlate
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> World
placePressPlate pp p rot = over pressPlates addPP
  where 
    addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps

placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
  where 
    cid = IM.newKey (_creatures w)
    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 

placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot = over creatures addCr
  where 
    addCr crs = IM.insert 
        (IM.newKey crs) 
        (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs}) 
        crs

placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World
placeLS ls dec (x,y,z) rot w = over lightSources addLS $ over decorations addDec w
  where 
    addLS lss = IM.insert 
        (IM.newKey lss) 
        (ls {_lsPos = (x,y,z),_lsDir = rot,_lsID = IM.newKey lss}) 
        lss
    addDec decs = IM.insert 
        (IM.newKey decs) 
        (translate x y $ rotate (negate rot) dec)
        decs