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

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

-- when placing a placement, we update the world and the room and assign an id
-- to the placement
placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] )
placeSpot (w,rm) plmnt = case plmnt of
    Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
    Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
    Placement{} -> placePlainPSSpot w rm plmnt shift
    PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
    RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
    PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
  where
    shift = _rmShift rm

placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld
placePickOne i pl rm w = w & gPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]

placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement])
placeRandomPlacement rplmnt w rm = placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
  where
    (plmnt', g) = runState rplmnt (_randGen $ _gWorld w)

placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement])
placePlainPSSpot w rm plmnt shift = 
    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)

-- this should be tidied up
placeSpotUsingLink :: GenWorld 
    -> Room 
    -> Placement 
    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
    -> (RoomPos -> Room -> Room)
    -> Maybe Placement
    -> ((GenWorld, Room), [Placement])
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
    Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
    Nothing -> case fallback of
        Nothing -> ((w,rm),[plmnt])
        Just plmnt' -> placeSpot (w,rm) plmnt'
  where
    searchedPoss [] = Nothing
    searchedPoss (pos:poss) = case extract pos rm of
        Nothing -> second (pos:) <$> searchedPoss poss
        Just (ps,rmpos) -> Just ( ps,rmpos:poss)

placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot) 
    -> Placement -> GenWorld -> ((GenWorld,Room),[Placement])
placeSpotRoomRand rm i f plmnt w =
    let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w)
    in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps)

-- the Int here is some id that is assigned when the placement is placed
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt w = case pt of
    PutTrigger  cnd         -> placeNewInto triggers cnd w
    PutMod      mdi         -> plNewUpID modifications mdID mdi w
    PutProp     prp         -> plNewUpID props pjID (mvProp p rot prp) 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 pps mc  -> placeMachine col (map doShift pps) mc p rot w
    PutLS       ls          -> plNewUpID lightSources lsID (mvLS p' rot ls) w
    PutPPlate   pp          -> plNewUpID pressPlates ppID (mvPP p rot pp) w
    RandPS      rgn         -> evaluateRandPS rgn ps w
    PutDoor     col f   pss -> placeDoor col f (map (bimap doShift doShift) pss) w
    PutCoord    cp          -> placeNewInto coordinates (doShift cp) w
    PutSlideDr  pth col f  a   b spd 
                            -> placeSlideDoor pth col f (doShift a) (doShift b) spd w
    PutBlock    bm  hp  hps wl  ps' 
                            -> placeBlock (map doShift ps') hp wl hps bm w
    PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
    PutWall     qs  wl      -> (0,placeWallPoly (map doShift qs) wl w)
    PutShape    sh          -> placeShape sh p rot w
    PutNothing              -> (0,w)
    PutID i                 -> (i, w)
    PutWorldUpdate f        -> (0,w & gWorld %~ f ps)
  where 
    p@(V2 px py) = _psPos ps
    p' = V3 px py 0
    rot = _psRot ps
    doShift = shiftPointBy (p,rot)

placeShape :: Shape -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
placeShape sh p rot w = 
    (0, w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))

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

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

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
    -> GenWorld
    -> (Int,GenWorld)
placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x)
  where
    i = IM.newKey $ _gWorld w ^# l

-- | place an new object into an intmap and update its id
plNewUpID :: ALens' World (IM.IntMap a)
    -> ALens' a Int
    -> a
    -> GenWorld
    -> (Int,GenWorld)
plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i))
  where
    i = IM.newKey $ _gWorld 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 -> GenWorld -> (Int,GenWorld)
placeMachine color wallpoly mc p rot w = (mcid
    , w & gWorld . machines  %~ addMc
        & gWorld . walls     %~ placeMachineWalls color wallpoly mcid wlid
    )
  where 
    w' = _gWorld w
    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
