--{-# 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 Control.Monad.State
import Data.Bifunctor
import Data.Foldable
import qualified Data.IntSet as IS
import Data.Maybe
import qualified Data.Set as S
import Dodge.Base.NewID
import Dodge.Data.GenWorld
import Dodge.Default.Wall
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 Linear
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 :: Int -> GenWorld -> Placement -> GenWorld
placeSpot rid w plmnt = case plmnt ^. plSpot of
    PSRoomRand i f -> placeSpotRoomRand rid i f plmnt w
    PSPos extract eff fallback -> placeSpotUsingLink w rid plmnt extract eff fallback
    _ -> placePlainPSSpot w rid plmnt shift
  where
    shift = _rmShift $ w ^?! genRooms . ix rid

placePlainPSSpot :: GenWorld -> Int -> Placement -> Point2A -> GenWorld
placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
    RandPS rgn ->
        let (x, g) = runState rgn (w ^. gwWorld . randGen)
         in placePlainPSSpot (w & gwWorld . randGen .~ g) rid (plmnt & plType .~ x) shift
    _ ->
        let (i, w') = placeSpotID rid (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
            newplmnt = plmnt & plMID ?~ i
            gw =
                maybe
                    (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
                    (recrPlace newplmnt w')
                    (_plIDCont plmnt w' newplmnt)
         in f newplmnt gw
  where
    f x gw = fromMaybe gw $ do
        j <- x ^. plExternalID
        return $ gw & genPmnt . at j ?~ x
    recrPlace newplmnt w' pl =
        placeSpot
            rid
            (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
            pl

-- this should be tidied up
placeSpotUsingLink ::
    GenWorld ->
    Int ->
    Placement ->
    (RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) ->
    (RoomPos -> Room -> Room) ->
    Maybe Placement ->
    GenWorld
placeSpotUsingLink w rid plmnt extract eff fallback =
    case searchedPoss (w ^?! genRooms . ix rid . rmPos) of
        Just (ps, rmposs) ->
            placeSpot
                rid
                (w & genRooms . ix rid %~ eff (head rmposs) . (rmPos .~ rmposs))
                (plmnt & plSpot .~ ps)
        Nothing -> maybe w (placeSpot rid w) fallback
  where
    searchedPoss [] = Nothing
    searchedPoss (pos : poss) = case extract pos (w ^?! genRooms . ix rid) of
        Nothing -> second (pos :) <$> searchedPoss poss
        Just (ps, rmpos) -> Just (ps, rmpos : poss)

placeSpotRoomRand ::
    Int ->
    Int ->
    (Point2A -> PlacementSpot) ->
    Placement ->
    GenWorld ->
    GenWorld
placeSpotRoomRand rid i f plmnt w =
    let (ps, g) =
            runState
                (_rmRandPSs (w ^?! genRooms . ix rid) !! i)
                $ w ^. gwWorld . randGen
     in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps)

-- the Int here is some id that is assigned when the placement is placed
placeSpotID :: Int -> PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID rid ps pt w = case pt of
    PutTrigger cnd -> plNewID (gwWorld . cWorld . lWorld . triggers) cnd w
    PutMod mdi -> plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w
    PutProp prp -> plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w
    PutButton bt ->
        plNewUpID
            (gwWorld . cWorld . lWorld . buttons)
            btID
            (mvButton p rot bt)
            w
    PutTerminal tm -> plNewUpID (gwWorld . cWorld . lWorld . terminals) tmID tm w
    PutFlIt itm ->
        let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
         in ( i
            , w
                & gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot
                & gwWorld . cWorld . lWorld . items . at i
                    ?~ ( itm & itID .~ NInt i
                            & itLocation .~ OnFloor
                       )
            )
    PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
    PutForeground fs ->
        (0, w & gwWorld . cWorld . lWorld . foreShapes .:~ mvFS p rot fs)
    PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
    PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
    RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
    PutDoor dr wl -> plDoor (dr & drZeroPos %~ pashift & drOnePos %~ pashift) wl w
    PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) 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, over gwWorld (placeWallPoly (map doShift qs) wl) w)
    PutNothing -> (0, w)
    PutID i -> (i, w)
    PutWorldUpdate f -> (0, w & f rid ps)
    PutChasm ps' -> (0, placeChasm w rid ps' $ map doShift ps')
    PutLabel{} -> (0, w)
  where
    p@(V2 px py) = _psPos ps
    p' = V3 px py 0
    rot = _psRot ps
    doShift = shiftPointBy (p, rot)
    pashift = compP2A (p, rot)

placeChasm :: GenWorld -> Int -> [Point2] -> [Point2] -> GenWorld
placeChasm gw rid ps shiftps =
    gw & gwWorld . cWorld . chasms .:~ shiftps
        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ pointInPoly (_rpPos rp) ps)
        & gwWorld %~ f
  where
    f w = foldl' g w (loopPairs shiftps)
    g w (x, y) = obstructPathsCrossing (S.singleton ChasmObstacle) x y w

placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly qs wl w
    | (p : ps) <- orderPolygon qs = foldl' (addPane wl) w $ zip (ps ++ [p]) (p : ps)
    | otherwise = error "tried to place wall poly with too few points"

addPane :: Wall -> World -> (Point2, Point2) -> World
addPane wl w l = insertWall (wl & wlLine .~ l & wlID .~ i) w
  where
    i = IM.newKey $ w ^. cWorld . lWorld . walls

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))

mvCr :: Point2 -> Float -> Creature -> Creature
mvCr p rot =
    (crPos . _xy .~ p)
        . (crOldPos . _xy .~ p)
        . (crDir .~ rot)

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

plMachine ::
    [Point2] ->
    Machine ->
    Maybe Item ->
    Point2 ->
    Float ->
    GenWorld ->
    (Int, GenWorld)
plMachine wallpoly mc mitm p rot gw =
    ( mcid
    , gw & tolw . machines . at mcid ?~ themc
        & gwWorld %~ placeMachineWalls wallpoly mcid wlid
        & tolw %~ maybe id placeturretitm mitm
    )
  where
    tolw = gwWorld . cWorld . lWorld
    mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
    wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
    wlids = IS.fromList $ take (length wallpoly) [wlid ..]
    themc = mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
    placeturretitm itm =
        (items . at itid ?~ itm')
            . (machines . ix mcid . mcType . mctTurret . tuWeapon .~ itid)
      where
        itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
        itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid

placeMachineWalls :: [Point2] -> Int -> Int -> World -> World
placeMachineWalls poly mcid = insertStructureWalls MachinePart baseWall poly mcid
  where
    baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid

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)