{-# 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.LevelGen.Block
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 Dodge.Default.Wall
import Geometry
import Geometry.Vector3D
import Shape
import qualified IntMapHelp as IM
import Color

import Control.Monad.State
import Control.Lens
import qualified Data.IntSet as IS

placeSpot :: World -> ((Point2,Float) , Placement) -> World
placeSpot w (shift, plmnt) =
    let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w
    in  maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)

shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps)
     (fmap (fmap $ shiftPlacement shift) f)

shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
shiftPSBy (pos,rot) ps = ps
    & psPos %~ shiftPointBy (pos,rot)
    & psRot %~ (+ rot)

-- the Int here allows for passing parameters down to other placements:
-- button ids, etc
placeSpotID :: PlacementSpot -> World -> (Int, World)
placeSpotID ps w = case _psType ps of
    PutProp prop -> placeProp prop p rot w
    PutButton bt -> placeBt bt p rot w
    PutFlIt itm -> placeFlIt itm p rot w
    PutCrit cr -> placeCr cr p rot w
    PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
    PutLS ls -> placeLS ls p' rot w
    PutPressPlate pp -> placePressPlate pp p rot w
    RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
      where 
        (evaluatedType, g) = runState rgen (_randGen w)
    PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w
      where 
        mapBoth fn (x,y) = (fn x, fn y) 
    PutSingleDoor col f a b speed 
        -> putSingleDoor False col f (doShift a) (doShift b) speed w
    PutDoubleDoor col f a b speed 
        -> (,) 0 $ insertDoubleDoor False col f (doShift a) (doShift b) speed w
    PutAutoDoor a b -> (,) 0 $ addAutoDoor (doShift a) (doShift b) w
    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
    PutBlock{} -> error "messed up block placement somehow"
    PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot) 
                            (doShift a) (doShift b) speed w
    PutLineBlock wl width depth a b
        -> placeLineBlock wl width depth (doShift a) (doShift b) w
    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
      where 
        qs = map doShift ps'
        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
    PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
    PutNothing -> (0,w)
    PutID i -> (i, w)
    --_   -> w
  where 
    p@(V2 px py) = _psPos ps
    p' = V3 px py 0
    rot = _psRot ps
    doShift = shiftPointBy (p,rot)

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

placeProp 
    :: Prop
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> (Int, World)
placeProp pr p a w = (i, w & props %~ addProp)
  where 
    i = IM.newKey $ _props w
    addProp prs = IM.insert i (f pr) prs
    f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) . (pjID .~ i)

placeBt 
    :: Button
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> (Int, World)
placeBt bt p a w = (i , over buttons addBT w)
  where 
    i = IM.newKey $ _buttons w
    addBT xs = IM.insert i (f bt) xs
    f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i)
    --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
    -> (Int, World)
placeFlIt itm p rot w = (i, w & floorItems %~ 
    \ fis -> IM.insert i 
        (FlIt
            { _flItPos = p
            , _flItRot = rot
            , _flItID = i
            , _flIt = itm
            }
        ) fis
    )
  where
    i = IM.newKey $ _floorItems w

placePressPlate
    :: PressPlate
    -> Point2
    -> Float -- ^ Rotation
    -> World
    -> (Int, World)
placePressPlate pp p rot w = (i , over pressPlates addPP w)
  where 
    i = IM.newKey $ _pressPlates w
    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 -> (Int,World)
placeCr crF p rot w = (cid, over creatures addCr w)
  where 
    cid = IM.newKey $ _creatures w
    addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs

placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
placeMachine color wallpoly mc p rot w = (mcid
    , w & machines  %~ addMc
        & walls     %~ placeMachineWalls color wallpoly mcid wlid
    )
  where 
    mcid = IM.newKey $ _machines w
    wlid = IM.newKey $ _walls w
    wlids = IS.fromList [wlid .. wlid + length wallpoly]
    addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
  where
    f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
    baseWall = defaultMachineWall 
        & wlColor .~ col
        & wlStructure . wlStMachine .~ mcid

placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World)
placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
  where 
    i = IM.newKey $ _lightSources w
    startPos = onXY (rotateV rot) $ _lsPos ls
    addLS lss = IM.insert 
        (IM.newKey lss) 
        (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss}) 
        lss