{-# 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.Placement.Shift
import Dodge.Data
--import Dodge.Path
import Dodge.Placement.PlaceSpot.Block
import Dodge.Placement.PlaceSpot.TriggerDoor
import Dodge.Default.Wall
import Dodge.ShiftPoint
import Dodge.Base.NewID
import Geometry
import qualified IntMapHelp as IM
import Color

import Data.Foldable
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 :: (World,Room) -> Placement -> ( (World,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 -> World -> World
placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]

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

placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,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 w' newplmnt)
  where
    recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
                    in (wr,newplmnt:newplmnts)

-- this should be tidied up
placeSpotUsingLink :: World 
    -> Room 
    -> Placement 
    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
    -> (RoomPos -> Room -> Room)
    -> Maybe Placement
    -> ((World, 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 -> World -> ((World,Room),[Placement])
placeSpotRoomRand rm i f plmnt w =
    let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
    in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps)

-- the Int here is some id that is assigned when the placement is placed
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
placeSpotID ps pt w = case pt of
    PutTrigger  cnd         -> plNewID   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
    PutTerminal tm          -> plNewUpID terminals tmID tm w
    PutFlIt     itm         -> plNewUpID floorItems flItID (createFlIt p rot itm) w
    PutCrit     cr          -> plNewUpID creatures crID (mvCr p rot cr) w
    PutForeground fs        -> plNewUpID shapes fsID (mvFS p rot fs) w
    PutMachine  pps mc      -> plMachine (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 -> plDoor col f (map (bimap doShift doShift) pss) w
    PutCoord    cp          -> plNewID   coordinates (doShift cp) w
    PutSlideDr  wl dr off  a   b 
                            -> plSlideDoor wl dr off (doShift a) (doShift b) w
    PutBlock    bl wl  ps'  -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
                                    wl w
    PutLineBlock wl wdth a b     -> plLineBlock wl wdth (doShift a) (doShift b) w
    PutWall     qs  wl      -> (0,placeWallPoly (map doShift qs) wl w)
    PutNothing              -> (0,w)
    PutID i                 -> (i, w)
    PutWorldUpdate f        -> (0, w & f ps)
    PutUsingGenParams f     ->  let (w',pt') = f w
                                in placeSpotID ps pt' 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 (placeWalls ps wl)
--  where
--    rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps

placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
placeWalls qs wl wls = foldl' (addPane wl) wls pairs
  where 
    (p:ps) = orderPolygon qs
    pairs = zip (ps ++ [p]) (p:ps)

addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall
addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
  where
    wlid = IM.newKey wls

---- | 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) . (prPos %~ ( (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}

mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a ))

plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
plMachine wallpoly mc p rot gw = (mcid
    , gw & machines  %~ addMc
         & walls     %~ placeMachineWalls color wallpoly mcid wlid
    )
  where 
    color = _mcColor mc
    w' = gw
    mcid = IM.newKey $ _machines w'
    wlid = IM.newKey $ _walls w'
    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
    --addMc = IM.insert mcid (mc {_mcPos = centroid wallpoly,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
    addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})

-- 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 . wsMachine .~ mcid
        & wlTouchThrough .~ True

mvLS :: Point3 -> Float -> LightSource -> LightSource
mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
    & lsDir .~ rot
  where
    startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)