-- {-# 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 Control.Monad.Trans.State.Lazy
import Data.Bifunctor
import Data.Foldable
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

-- 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 -> placeSpotUsingRoomPos 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' =
        placeSpot rid (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)

-- this should be tidied up
placeSpotUsingRoomPos ::
    GenWorld ->
    Int ->
    Placement ->
    (RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) ->
    (RoomPos -> Room -> Room) ->
    Maybe Placement ->
    GenWorld
placeSpotUsingRoomPos 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
                (w ^?! genRooms . ix rid . rmRandPSs . ix 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 mc mitm -> plMachine (mc & mcPos .~ p & mcDir .~ rot) mitm 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' qs ->
        ( 0
        , placeChasm
            rid
            ps'
            (map (map doShift) ps')
            (foldMap (loopPairs . map doShift) qs)
            w
        )
    PutLabel{} -> (0, w)
  where
    p = _psPos ps
    rot = _psRot ps
    doShift = shiftPointBy (p, rot)
    pashift = compP2A (p, rot)

placeChasm :: Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld -> GenWorld
placeChasm rid ps shiftps cfs =
    (gwWorld . cWorld . chasms <>~ shiftps)
        . (gwWorld . cWorld . cliffs <>~ cfs)
        . (genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps))
        . (gwWorld %~ f)
  where
    f w = foldl' g w cfs
    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 :: Machine -> Maybe Item -> GenWorld -> (Int, GenWorld)
plMachine mc mitm gw =
    ( mcid
    , gw
        & tolw . machines . at mcid ?~ themc
        & tolw %~ maybe id placeturretitm mitm
        & gwWorld %~ addwalls
    )
  where
    p = mc ^. mcPos
    rot = mc ^. mcDir
    addwalls =
        insertStructureWalls
            MachinePart
            wl
            (map fst pps & each %~ shiftPointBy (p,rot))
            mcid
            wlid
    pps = IM.elems $ mc ^. mcFootPrint
    wl = 
        defaultMachineWall
            & wlStructure . wsMachine .~ mcid
            & wlMaterial .~ (mc ^. mcSkin)
    tolw = gwWorld . cWorld . lWorld
    mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
    wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
    themc = mc
        & mcID .~ mcid
        & mcFootPrint .~ IM.fromDistinctAscList (zip [wlid..] pps)
    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

mvLS :: Point2 -> Float -> LightSource -> LightSource
mvLS x rot = lsParam . lsPos . _xy %~ ((+ x) . rotateV rot)