{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

{- | 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 Color
import Control.Monad.State
import Data.Bifunctor
import Data.Foldable
import qualified Data.IntSet as IS
import Dodge.Base.NewID
import Dodge.Data.GenWorld
import Dodge.Path
import Dodge.Placement.PlaceSpot.Block
import Dodge.Placement.PlaceSpot.TriggerDoor
import Dodge.Placement.Shift
import Dodge.ShiftPoint
import Geometry
import qualified IntMapHelp as IM
import LensHelp
import NewInt
import System.Random

-- when placing a placement, we update the world and the room and assign an id
-- to the placement. This id should be associated with the type of placement and
-- match up with the created id for the object (creature id, flitid id, etc)
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
  where
    shift = _rmShift rm

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 (_gwWorld w') 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) $ w ^. gwWorld . randGen
     in placeSpot (w & gwWorld . randGen .~ g, rm) (plmnt & plSpot .~ f ps)

placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt gw =
    let (i, w) = placeSpotID' ps pt (_gwWorld gw)
     in (i, gw & gwWorld .~ w)

-- 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 (cWorld . lWorld . triggers) cnd w
    PutMod mdi -> plNewUpID (cWorld . lWorld . modifications) mdID mdi w
    PutProp prp -> plNewUpID (cWorld . lWorld . props) prID (mvProp p rot prp) w
    PutButton bt -> plNewUpID (cWorld . lWorld . buttons) btID (mvButton p rot bt) w
    PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w
    PutFlIt itm ->
        let i = IM.newKey (w ^. cWorld . lWorld . items)
         in ( i
            , w
                & cWorld . lWorld . floorItems . at i ?~ FlIt p rot
                & cWorld . lWorld . items . at i
                    ?~ ( itm & itID .~ NInt i
                            & itLocation .~ OnFloor
                       )
            )
    PutCrit cr -> plNewUpID (cWorld . lWorld . creatures) crID (mvCr p rot cr) w
    PutForeground fs -> plNewUpID (cWorld . lWorld . foregroundShapes) fsID 
        (mvFS p rot fs) w
    PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
    PutLS ls -> plNewUpID (cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
    PutPPlate pp -> plNewUpID (cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
    RandPS rgn -> evaluateRandPS rgn ps w
    PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
    PutCoord cp -> plNewID coordinates (doShift cp) w
    PutSlideDr wl dr eo off a b ->
        plSlideDoor wl dr eo 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)
    PutChasm ps' -> (0, w & cWorld . chasms .:~ map doShift ps')
  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)

-- this function is the reason for the warning suppression
-- remove the warning suppression if it changes
placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly qs wl w = foldl' (addPane wl) w pairs
  where
    (p : ps) = orderPolygon qs
    pairs = zip (ps ++ [p]) (p : ps)

addPane :: Wall -> World -> (Point2, Point2) -> World
addPane wl w l =
    w & plNew (cWorld . lWorld . walls) wlID (wl & wlLine .~ l)
        & fst . uncurry (obstructPathsCrossing WallObstacle) l

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

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

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 -> Wall -> Maybe Item -> Point2 -> Float -> World -> (Int, World)
plMachine wallpoly mc wl = \case
    Nothing -> plMachine' wallpoly mc wl
    Just itm -> plTurret wallpoly mc wl itm

plTurret :: [Point2] -> Machine -> Wall -> Item -> Point2 -> Float -> World -> (Int, World)
plTurret wallpoly mc wl itm p rot gw =
    ( mcid
    , gw & cWorld . lWorld . machines %~ addMc
        & cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
        & cWorld . lWorld . items . at itid ?~ itm'
    )
  where
    itm' =
        itm & itID .~ NInt itid
            & itLocation .~ OnTurret mcid
    itid = IM.newKey $ gw ^. cWorld . lWorld . items
    col = _mcColor mc
    mcid = IM.newKey $ gw ^. cWorld . lWorld . machines
    wlid = IM.newKey $ gw ^. cWorld . lWorld . walls
    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
    addMc =
        IM.insert
            mcid
            ( mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
                & mcType . mctTurret . tuWeapon .~ itid
            )

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

-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
placeMachineWalls 
    :: Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
  where
    f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
    baseWall =
        wl
            & 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
  where
    startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)