module Dodge.Render.ShapePicture (
    worldSPic,
) where

import Control.Lens
import Control.Monad (guard)
import Data.Foldable
import qualified Data.Graph.Inductive as FGL
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as Set
import Dodge.Base
import Dodge.Creature.Picture
import Dodge.Creature.Picture.Awareness
import Dodge.Data.Universe
import Dodge.Debug.Picture
import Dodge.Draw
import Dodge.Flare
import Dodge.GameRoom
import Dodge.Graph
import Dodge.Path
import Dodge.Picture.SizeInvariant
import Dodge.RadarBlip
import Dodge.Render.InfoBox
import Dodge.Render.Label
import Dodge.Render.List
import Dodge.Render.Picture
import Dodge.ShortShow
import Dodge.SoundLogic.LoadSound
import Dodge.Viewpoints
import Dodge.WorldEvent.ThingsHit
import Dodge.Zoning
import Dodge.Zoning.Base
import Geometry
import Geometry.ConvexPoly
import qualified IntMapHelp as IM
import Padding
import Picture
import Shape
import ShapePicture
import ShortShow
import Sound.Data

worldSPic :: Configuration -> Universe -> SPic
worldSPic cfig u =
    (mempty, extraPics cfig u)
        <> foldup drawProp' (filtOn _prPos _props)
        <> foldup drawProjectile (filtOn _prjPos _projectiles)
        <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
        <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
        <> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
        <> foldup drawCreature (filtOn _crPos _creatures)
        <> foldup floorItemSPic (filtOn _flItPos _floorItems)
        <> foldup btSPic (filtOn _btPos _buttons)
        <> foldup mcSPic (filtOn _mcPos _machines)
        <> aimDelaySweep w
        <> anyTargeting cfig w
  where
    w = _uvWorld u
    foldup = foldMap'
    filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
    pointIsClose = cullPoint cfig w

aimDelaySweep :: World -> SPic
aimDelaySweep w = fromMaybe mempty $ do
    cr <- w ^? cWorld . lWorld . creatures . ix 0
    aimstatus <- cr ^? crStance . posture
    guard (aimstatus == Aiming)
    return $ noShape $ drawSweep cr w

drawSweep :: Creature -> World -> Picture
drawSweep cr w = fromMaybe mempty $ do
    a <- safeArgV (mwp -.- p)
    let a'
            | a - cdir > pi = cdir + 2 * pi
            | a - cdir < - pi = cdir - 2 * pi
            | otherwise = cdir
    return $
            setLayer FixedCoordLayer $
                uncurryV translate (worldPosToScreen campos p) $
                    arcFull (a - rot) 10 white (a' - rot) 1 white (5 + dist mwp p * campos ^. camZoom) white
  where
    cdir = _crDir cr
    rot = campos ^. camRot
    p = _crPos cr
    campos = w ^. cWorld . cwCamPos
    theinput = w ^. input
    mwp = mouseWorldPos theinput campos

anyTargeting :: Configuration -> World -> SPic
anyTargeting cfig w = fromMaybe mempty $ do
    tt <- cr ^? crTargeting . ctType . _Just
    return $ noShape $ drawTargeting tt cr cfig w
  where
    cr = you w

drawCreature :: Creature -> SPic
drawCreature cr = case _crType cr of
    Humanoid{} -> basicCrPict cr
    Barreloid{} ->
        picAtCrPos1
            ( setDepth 20 $
                pictures
                    [ color orange $ circleSolid 10
                    , setDepth 0.049 . color (greyN 0.5) $ circleSolid 8
                    , color (greyN 0.5) $ circleSolid 8
                    ]
            )
            cr
    Lampoid{_lampHeight = h} -> uncurryV translateSPxy (_crPos cr) $ lampCrSPic h
    NonDrawnCreature -> mempty

lampCrSPic :: Float -> SPic
lampCrSPic h =
    ( colorSH blue . upperBox h $ rectWH 5 5
    , setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
    )

picAtCrPos1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic

shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
shiftDraw fpos fdir fdraw x =
    uncurryV translateSPxy (fpos x)
        . rotateSP (fdir x)
        $ fdraw x x

shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
shiftDraw' fpos fdir fdraw x =
    uncurryV translateSPxy (fpos x)
        . rotateSP (fdir x)
        $ fdraw x

cullPoint :: Configuration -> World -> Point2 -> Bool
cullPoint cfig w p
    | debugOn Close_shape_culling cfig = pointInPolygon p (w ^. cWorld . cwCamPos . camBoundBox)
    | otherwise = dist (w ^. cWorld . cwCamPos . camCenter) p < (w ^. cWorld . cwCamPos . camViewDistance)

extraPics :: Configuration -> Universe -> Picture
extraPics cfig u =
    pictures (_decorations lw)
        <> setLayer FixedCoordLayer (fixedCoordPictures u)
        <> concatMapPic drawTractorBeam (_tractorBeams lw)
        <> concatMapPic drawLinearShockwave (_linearShockwaves lw)
        <> concatMapPic drawShockwave (_shockwaves lw)
        <> concatMapPic drawLaser (_lasersToDraw lw)
        <> concatMapPic drawTeslaArc (_teslaArcs lw)
        <> concatMapPic drawRadarSweep (_radarSweeps lw)
        <> concatMapPic drawFlame (_flames lw)
        <> concatMapPic drawEnergyBall (_energyBalls lw)
        <> concatMapPic drawSpark (_sparks lw)
        <> concatMapPic drawBul (_bullets lw)
        <> concatMapPic drawBlip (_radarBlips lw)
        <> concatMapPic drawFlare (_flares lw)
        <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams lw)
        <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams lw)
        <> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources lw)
        <> testPic cfig w
        <> concatMapPic ppDraw (_pressPlates lw)
        <> viewClipBounds cfig w
        <> debugDraw cfig w
  where
    w = u ^. uvWorld
    lw = w ^. cWorld . lWorld

debugDraw :: Configuration -> World -> Picture
{-# INLINE debugDraw #-}
debugDraw cfig w
    | Show_debug `Set.member` _debug_booleans cfig =
        pic
            <> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts)
    | otherwise = mempty
  where
    pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
    ts = map show (Set.toList $ _debug_booleans cfig)

debugDraw' :: Configuration -> World -> DebugBool -> Picture
{-# INLINE debugDraw' #-}
debugDraw' cfig w bl = case bl of
    Show_debug -> mempty
    Noclip -> mempty
    Remove_LOS -> mempty
    Cull_more_lights -> mempty
    Close_shape_culling -> mempty
    Bound_box_screen -> mempty
    Show_ms_frame -> mempty
    View_boundaries -> viewBoundaries (w ^. cWorld)
    Show_bound_box -> drawBoundingBox w
    Show_wall_search_rays -> drawWallSearchRays w
    Show_dda_test -> drawDDATest w
    Show_far_wall_detect -> drawFarWallDetect w
    Show_walls_near_point_cursor -> drawWallsNearCursor w
    Show_walls_near_point_you -> drawWallsNearYou w
    Show_zone_near_point_cursor -> drawZoneNearPointCursor w
    Show_select -> drawWorldSelect w
    Inspect_wall -> drawInspectWalls w
    Cr_awareness -> drawCreatureDisplayTexts w
    Show_sound -> pictures $ M.map (soundPic cfig w) $ _playingSounds w
    Cr_status -> drawCrInfo cfig (w ^. cWorld)
    Mouse_position -> drawMousePosition w
    Walls_info -> drawWlIDs w
    Pathing -> drawPathing cfig w
    Show_nodes_near_select -> undefined --drawNodesNearSelect w
    Show_path_between -> drawPathBetween w
    Collision_test -> drawCollisionTest w

drawCollisionTest :: World -> Picture
drawCollisionTest w =
    setLayer DebugLayer (color orange $ line [a, b])
        <> foldMap (drawCross . fst) (crHit a b w)
        <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
        <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
        <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
        <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b)
  where
    (a, b) = _lrLine (_input w)

drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)

drawPathBetween :: World -> Picture
drawPathBetween w =
    setLayer DebugLayer $
        color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
            <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
            <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
            <> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
  where
    nodepos = (`getNodePos` w)
    nodelist = makePathBetween sp ep w
    sp = _lSelect (_input w)
    ep = _rSelect (_input w)

drawWallsNearYou :: World -> Picture
drawWallsNearYou w = fromMaybe mempty $ do
    p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
    return $ setLayer DebugLayer $ foldMap f $ wlsNearPoint p w
  where
    f wl = color violet $ thickLine 3 [a, b]
      where
        (a, b) = _wlLine wl

drawWallsNearCursor :: World -> Picture
drawWallsNearCursor w =
    setLayer DebugLayer $ foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_cwCamPos $ _cWorld w)) w
  where
    f wl = color rose $ thickLine 3 [a, b]
      where
        (a, b) = _wlLine wl

drawInspectWalls :: World -> Picture
drawInspectWalls w =
    setLayer DebugLayer (color orange $ line [a, b])
        <> foldMap
            (drawInspectWall w)
            ( filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $
                IM.elems $ w ^. cWorld . lWorld . walls
            )
  where
    (a, b) = _lLine (_input w)

drawInspectWall :: World -> Wall -> Picture
drawInspectWall w wl =
    setLayer DebugLayer $
        color rose (thickLine 3 [a, b])
            <> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
  where
    (a, b) = _wlLine wl

drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = fromMaybe mempty $ do
    paths <- w ^? cWorld . lWorld . doors . ix drid . drObstructs
    return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths

drawPathEdge :: PathEdge -> Picture
drawPathEdge pe =
    setLayer DebugLayer $
        multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe))

obstacleColor :: EdgeObstacle -> Color
obstacleColor eo = case eo of
    WallObstacle -> cyan
    DoorObstacle -> red
    AutoDoorObstacle -> yellow
    BlockObstacle -> blue

drawWorldSelect :: World -> Picture
drawWorldSelect w =
    setLayer DebugLayer $
        color cyan (line [a, b])
            <> color magenta (line [c, d])
  where
    (a, b) = _lLine (_input w)
    (c, d) = _rLine (_input w)

drawFarWallDetect :: World -> Picture
drawFarWallDetect w =
    setLayer DebugLayer
        . color yellow
        . foldMap
            ( \q ->
                line
                    [ p
                    , fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
                    ]
            )
        $ getViewpoints p (_cWorld w)
  where
    p = w ^. cWorld . cwCamPos . camViewFrom

drawZoneNearPointCursor :: World -> Picture
drawZoneNearPointCursor w =
    foldMap (drawZoneCol orange 50) ps
  where
    mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos)
    ps = [zoneOfPoint 50 mwp]

drawDDATest :: World -> Picture
drawDDATest w =
    foldMap (drawZoneCol orange 50) ps
        <> setLayer DebugLayer (color yellow (line [cvf, mwp]))
  where
    cvf = w ^. cWorld . cwCamPos . camViewFrom
    mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos)
    ps = zoneOfSeg 50 cvf mwp

drawZoneCol :: Color -> Float -> V2 Int -> Picture
drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
  where
    (p : ps) =
        zipWith (+.+) innerSquare $
            map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]

innerSquare :: [Point2]
innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]

drawWallSearchRays :: World -> Picture
drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
  where
    f p =
        setLayer DebugLayer $
            color yellow $
                uncurryV translate p (circle 5)
                    <> line [w ^. cWorld . cwCamPos . camViewFrom, p]

testPic :: Configuration -> World -> Picture
testPic _ _ = mempty

drawBoundingBox :: World -> Picture
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
  where
    (x : xs) = w ^. cWorld . cwCamPos . camBoundBox

ppDraw :: PressPlate -> Picture
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)

floorItemSPic :: FloorItem -> SPic
floorItemSPic flit =
    uncurryV translateSPxy (_flItPos flit) $
        rotateSP (_flItRot flit) (itemSPic (_flIt flit))

btSPic :: Button -> SPic
btSPic bt =
    uncurryV translateSPxy (_btPos bt) $
        rotateSP (_btRot bt) (drawButton (_btPict bt) bt)

mcSPic :: Machine -> SPic
mcSPic mc =
    uncurryV translateSPxy (_mcPos mc) $
        rotateSP (_mcDir mc) (drawMachine mc)

soundPic :: Configuration -> World -> Sound -> Picture
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig (w ^. cWorld)
  where
    p = _soundPos s
    thePic =
        rotate (w ^. cWorld . cwCamPos . camRot)
            . scale theScale theScale
            . centerText
            . soundToOnomato
            $ _soundChunkID s
    theScale = 0.15 * f (_soundVolume s * 0.0001)
    f x = 1 - 0.5 * (1 - x)

drawMousePosition :: World -> Picture
drawMousePosition w =
    setLayer FixedCoordLayer
        . uncurryV translate (w ^. input . mousePos)
        . scale 0.1 0.1
        . text
        $ shortPoint2 mwp
  where
    mwp = mouseWorldPos (w ^. input) (w ^. cWorld . cwCamPos)

drawWlIDs :: World -> Picture
drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls)
  where
    f wl
        | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test"
        | otherwise =
                uncurryV translate p
                . scale 0.1 0.1
                . text
                $ show $ _wlID wl
      where
        p = worldPosToScreen (w ^. cWorld . cwCamPos) $ 0.5 *.* uncurry (+.+) (_wlLine wl)

edgeToPic :: [Point2] -> PathEdge -> Picture
edgeToPic poly pe
    | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
    | otherwise = drawPathEdge pe
  where
    sp = _peStart pe
    ep = _peEnd pe

drawPathing :: Configuration -> World -> Picture
drawPathing cfig w =
    setLayer DebugLayer $
        foldMap (edgeToPic (screenPolygon cfig (w ^. cWorld . cwCamPos)) . (^?! _3)) (FGL.labEdges gr)
            <> foldMap dispInc (graphToIncidence gr)
  where
    dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
    gr = w ^. cWorld . pathGraph

crDisplayInfo :: Configuration -> CamPos -> Creature -> Maybe (Point2, [String])
crDisplayInfo cfig cam cr
    | _crID cr == 0 = Nothing
    | crOnScreen =
        Just
            ( _crPos cr
            , catMaybes
                --        [fmap show $ ap ^? crGoal
                [ fpreShow "crHP" $ cr ^? crHP
                , fpreShow "crStrategy" $ ap ^? apStrategy
                , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos
                , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
                , --        , fmap show $ cr ^? crOldPos
                  fpreShow "crAction" $ ap ^? apAction
                , fpreShow "crImpulse" $ ap ^? apImpulse
                ]
            )
    | otherwise = Nothing
  where
    ap = _crActionPlan cr
    crOnScreen = pointOnScreen cfig cam $ _crPos cr

fpreShow :: (Show a, Functor f) => String -> f a -> f String
fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)

drawCrInfo :: Configuration -> CWorld -> Picture
drawCrInfo cfig w =
    setLayer FixedCoordLayer $
        renderInfoListsAt (2 * hw - 400) 0 cfig cam $
            mapMaybe (crDisplayInfo cfig cam) $ IM.elems $ w ^. lWorld . creatures
  where
    cam = w ^. cwCamPos
    hw = halfWidth cfig

viewBoundaries :: CWorld -> Picture
viewBoundaries w =
    setLayer DebugLayer $
        color green (foldMap (polygonWire . _grBound) grs)
            <> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p w)
  where
    p = w ^. cwCamPos . camViewFrom
    grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen w)

viewClipBounds :: Configuration -> World -> Picture
viewClipBounds cfig w
    | _debug_view_clip_bounds cfig == AllRoomClipBoundaries =
        setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_cwgRoomClipping $ _cwGen (_cWorld w))
    | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries =
        setLayer DebugLayer $ f (_cwgRoomClipping $ _cwGen (_cWorld w))
    | otherwise = mempty
  where
    f (x : xs) = g x xs <> f xs
    f [] = mempty
    g x (y : ys)
        | convexPolysOverlap x y =
            color green (polygonWire $ _cpPoints x)
                <> color yellow (polygonWire $ _cpPoints y)
                <> g x ys
        | otherwise = g x ys
    g _ [] = mempty