{-# LANGUAGE BangPatterns #-}
{-# 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.Base
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 Picture

import System.Random
import Control.Monad.State
import Control.Applicative
import Control.Lens
import Data.List
import Data.Function
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Set as S
import qualified Data.Map as M


placeSpots :: [Placement] -> World -> World
placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements
  where
    (singlePlacements, groupedPlacements) = partition isSPS pss
    isSPS (SinglePlacement {}) = True
    isSPS _ = False
    gplmnts = groupBy ((==) `on` _groupPlacementID) $ sortOn _groupPlacementID groupedPlacements
    w' = foldr updateGroup w gplmnts

{- | 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
    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])
    _   -> w
  where 
    p = _psPos ps
    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 (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 (newKey wls) (wl
    { _wlLine = (p0,p1)
    , _wlID = newKey wls
    })
    wls

placeBt bt p rot w = over buttons addBT w
  where 
    addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = 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 (newKey fis) 
        (FlIt
            { _flItPos = p
            , _flItRot = rot
            , _flItID = newKey fis
            , _flIt = itm
            }
        ) fis

placePressPlate pp p rot w = over pressPlates addPP w
  where 
    addPP pps = IM.insert (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 = newKey (_creatures w)
    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 

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

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