{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
-- | deals with placement of objects within the world
-- after they have had their coordinates set by the layout
module Dodge.LevelGen 
    ( shiftPlacement
    , shiftPointBy
    , invShiftPointBy
    , placeSpot
    ) where
import Dodge.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.TriggerDoor
import Dodge.LevelGen.Data
import Dodge.Default.Wall
import Dodge.RandomHelp
import Dodge.Placements.Spot
import Geometry
import Geometry.Vector3D
import Shape
import qualified IntMapHelp as IM
import Color

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

-- when placing a placement, we update the world and the room and assign an id
-- to the placement
placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
placeSpot (w,rm) plmnt = case plmnt of
    Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
    Placement{_plSpot = PSLnk{}}      -> placeSpotUsingLink w rm plmnt
    Placement{} ->
        let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
            newplmnt = plmnt & plMID ?~ i
        in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
      where
        recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
                        in (wr,newplmnt:newplmnts)
            -- (placeSpot (w',rm)) (_plIDCont plmnt i)
    PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
    RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt'
      where
        (plmnt', g) = runState rplmnt (_randGen w)
  where
    shift = _rmShift rm

placeSpotUsingLink :: World -> Room -> Placement -> ((World, Room), [Placement])
placeSpotUsingLink w rm plmnt = case lnks of
    ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
    [] -> case fallback of
        Nothing -> ((w,rm),[plmnt])
        Just plmnt' -> placeSpot (w,rm) plmnt'
  where
    uselnk lnki = rm & rmLinks %~ deletei lnki
    rps = _plSpot plmnt
    fallback = _psLnkFallback rps
    test = _psLnkTest rps
    (lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..] 
        $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
    f x (PSLnk t s _ _)
        | t x = uncurry PS $ s x
    f _ ps = ps
    invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
    invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)

placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
placeSpotRoomRand rm i plmnt w =
    let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
    in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)

deletei :: Int -> [a] -> [a]
deletei i xs = take i xs ++ drop (i+1) xs

shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift plmnt = case plmnt of
    Placement {} -> plmnt & plSpot %~ shiftPSBy shift 
        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
    PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
        (fmap (shiftPlacement shift) f)
    RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl

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 -> PSType -> World -> (Int, World)
placeSpotID ps pt w = case pt of
    PutTrigger cond -> placeNewInto triggers cond w
    PutProp prop    -> plNewUpID props pjID (mvProp p rot prop) w
    PutButton bt    -> plNewUpID buttons btID (mvButton p rot bt) w
    PutFlIt itm     -> plNewUpID floorItems flItID (createFlIt p rot itm) w
    PutCrit cr      -> plNewUpID creatures crID (mvCr p rot cr) w
    PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
    PutLS ls        -> plNewUpID lightSources lsID (mvLS p' rot ls) w
    PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
    RandPS rgen -> evaluateRandPS rgen ps w
    PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
    PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
    PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
    PutBlock{} -> error "messed up block placement somehow"
    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
    PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
    PutNothing -> (0,w)
    PutID i -> (i, w)
    PutWorldUpdate f -> (0,f ps w)
  where 
    p@(V2 px py) = _psPos ps
    p' = V3 px py 0
    rot = _psRot ps
    doShift = shiftPointBy (p,rot)

evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
  where 
    (evaluatedType, g) = runState rgen (_randGen w)

placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
  where
    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps

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

invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1

shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)

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 l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
  where
    wlid = IM.newKey wls

-- | generalised way of putting a new item into a lensed intmap, returning the
-- new index as well
placeNewInto :: ALens' World (IM.IntMap a)
    -> a
    -> World
    -> (Int,World)
placeNewInto l x w = (i,w & l #%~ IM.insert i x)
  where
    i = IM.newKey $ w ^# l

-- | place an new object into an intmap and update its id
plNewUpID :: ALens' World (IM.IntMap a)
    -> ALens' a Int
    -> a
    -> World
    -> (Int,World)
plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
  where
    i = IM.newKey $ w ^# l

mvProp :: Point2 -> Float -> Prop -> Prop
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))

mvButton :: Point2 -> Float -> Button -> Button
mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))

{- Creates a floor item at a given point.-}
createFlIt :: Point2 -> Float -> Item -> FloorItem
createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm }

mvPP :: Point2 -> Float -> PressPlate -> PressPlate
mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}

mvCr :: Point2 -> Float -> Creature -> Creature
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}

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

mvLS :: Point3 -> Float -> LightSource -> LightSource
mvLS (V3 x y z) rot ls = ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot}
  where
    startPos = onXY (rotateV rot) $ _lsPos ls