{-# 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
    ( shiftPlacement
    , shiftPointBy
    , invShiftPointBy
    , placeSpot
    ) where
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 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 :: (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 extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
    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

-- this should be tidied up
placeSpotUsingLink :: World -> Room -> Placement 
    -> (RoomPos -> Maybe PlacementSpot)
    -> (RoomPos -> Room -> Room)
    -> Maybe Placement
    -> ((World, Room), [Placement])
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
    Just (ps,pos,newrmpos) -> placeSpot (w, eff pos $ rm & rmPos .~ newrmpos) (plmnt & plSpot .~ ps)
    Nothing -> case fallback of
        Nothing -> ((w,rm),[plmnt])
        Just plmnt' -> placeSpot (w,rm) plmnt'
  where
    searchedPoss [] = error "no correct pos type for lnk placement"
    searchedPoss (pos:poss) = case extract pos of
        Nothing -> second (pos:) <$> searchedPoss poss
        Just ps -> Just ( ps,pos, poss)

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)

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


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