loop/src/Dodge/Debug/Picture.hs

{-# OPTIONS -Wno-incomplete-uni-patterns #-}
module Dodge.Debug.Picture where

import Linear (_xy)
import Control.Lens
import Data.Foldable
import qualified Data.Graph.Inductive as FGL
import Data.Maybe
import qualified Data.Set as S
import Dodge.Base
import Dodge.Creature.Picture.Awareness
import Dodge.Data.Universe
import Dodge.GameRoom
import Dodge.Graph
import Dodge.Path
import Dodge.Picture.SizeInvariant
--import Dodge.Render.InfoBox
import Dodge.Render.Label
import Dodge.Render.List
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 SDL (MouseButton (..))
--import ShortShow
import Sound.Data

printPoint :: Point2 -> Picture
printPoint p = color white $ uncurryV translate p $ fold [circle 3, scale 0.05 0.05 $ text (show p)]

printRotPoint :: Float -> Point2 -> Picture
printRotPoint r p =
    color white
        . uncurryV translate p
        $ fold [circle 3, rotate (negate r) $ scale 0.1 0.1 $ text (show p)]

outsideScreenPolygon :: Config -> Camera -> [Point2]
outsideScreenPolygon cfig w = [tr, tl, bl, br]
  where
    scRot = rotateV (w ^. camRot)
    scZoom p
        | (w ^. camZoom) /= 0 = (1 / (w ^. camZoom)) *.* p
        | otherwise = error "Trying to set screen zoom to zero"
    scTran p = p +.+ (w ^. camCenter)
    tr = f 3 3
    tl = f (-3) 3
    br = f 3 (-3)
    bl = f (-3) (-3)
    f a b = scTran $ scRot $ scZoom $ V2 (a * halfWidth cfig) (b * halfHeight cfig)

-- cannot only test if walls are on screen, but also if they are on the cone
-- towards the center of sight
lineOnScreenCone :: Config -> World -> Point2 -> Point2 -> Bool
lineOnScreenCone cfig w p1 p2 =
    pointInPoly p1 sp
        || pointInPoly p2 sp
        || any (isJust . uncurry (intersectSegSeg p1 p2)) sps
  where
    sp' = screenPolygon cfig (w ^. wCam)
    vp = w ^. wCam . camViewFrom
    sp
        | pointInPoly vp sp' = sp'
        | otherwise = orderPolygon ((w ^. wCam . camViewFrom) : sp')
    sps = zip sp (tail sp ++ [head sp])

drawWallFace :: Config -> World -> Wall -> Picture
drawWallFace cfig w wall
    | isRHS sightFrom x y || not (wlIsOpaque wall) = blank
    | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
  where
    (x, y) = _wlLine wall
    points = extendConeToScreenEdge cfig w sightFrom (x, y)
    sightFrom = w ^. wCam . camViewFrom

extendConeToScreenEdge :: Config -> World -> Point2 -> (Point2, Point2) -> [Point2]
extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs
  where
    borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x, y]
    scpoly = reverse $ screenPolygon cfig (w ^. wCam)
    cornerPs = filter (pointIsInCone c (x, y)) scpoly
    wallScreenIntersect =
        mapMaybe (uncurry $ intersectSegSeg y ((2 *.* y) -.- x))
            . loopPairs
            $ scpoly

-- the following assumes that the point a is inside the screen
-- it still works otherwise, but it might intersect two points:
-- it is not obvious which will be returned
intersectLinefromScreen :: Config -> World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen cfig w a b =
    listToMaybe
        . mapMaybe (\(x, y) -> intersectSegRay x y b (b +.+ b -.- a))
        . loopPairs
        $ screenPolygon cfig (w ^. wCam)

drawCollisionTest :: World -> Picture
drawCollisionTest w = concat $ do
    a <- w ^. input . heldWorldPos . at ButtonLeft
    b <- w ^. input . heldWorldPos . at ButtonRight
    return $
        setLayer DebugLayer (color orange $ line [a, b])
            <> foldMap
                ( drawCrossCol red
                    --                  . xyV3
                    . fst
                )
                --                (collide3 (v2z a 0) (v2z b 0) w)
                --                (collide3Floors (v2z a 10) (v2z b (-10)) $ w ^. cWorld . chasms)
                (thingHit a b w)

drawCircCollisionTest :: World -> Picture
drawCircCollisionTest w = concat $ do
    a <- w ^. input . heldWorldPos . at ButtonLeft
    b <- w ^. input . heldWorldPos . at ButtonRight
    let col
            | anythingHitCirc 2 a b w = red
            | otherwise = green
    return $
        setLayer DebugLayer (color col $ line [a, b])
            <> drawCoord a w
            <> drawCoord b w

drawWallsNearSegment :: World -> Picture
drawWallsNearSegment w = concat $ do
    a <- w ^. input . heldWorldPos . at ButtonLeft
    b <- w ^. input . heldWorldPos . at ButtonRight
    return . foldMap f $ wlsNearSeg a b w
  where
    f wl =
        setLayer DebugLayer (color rose $ thickLine 3 [a, b])
            <> drawCoord a w
            <> drawCoord b w
      where
        (a, b) = _wlLine wl

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

-- # OPTIONS -Wno-incomplete-uni-patterns #-}
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 (+.+) (square 1) $
            map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]

showEnabledDebugs :: Config -> Picture
{-# INLINE showEnabledDebugs #-}
showEnabledDebugs cfig
    | Enable_debug `S.member` _debug_booleans cfig =
        setLayer FixedCoordLayer (toTopLeft cfig (translate (0.5 * halfWidth cfig) 0 $ drawList $ map text ts))
    | otherwise = mempty
  where
    --    pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
    ts = map show (S.toList $ _debug_booleans cfig)

--debugDraw' :: Config -> World -> DebugBool -> Picture
--{-# INLINE debugDraw' #-}
--debugDraw' cfig w bl = case bl of
--    Enable_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 -> mempty
--    Show_bound_box -> mempty
--    Show_wall_search_rays -> mempty
--    Show_dda_test -> mempty
--    Show_far_wall_detect -> mempty
--    Show_walls_near_point_cursor -> mempty
--    Show_walls_near_segment -> mempty
--    Show_walls_near_point_you -> drawWallsNearYou w
--    Show_zone_near_point_cursor -> drawZoneNearPointCursor w
--    Show_zone_circ -> drawZoneCirc w
--    Inspect_wall -> drawInspectWalls w
--    Cr_awareness -> drawCreatureDisplayTexts w
--    Show_sound -> fold $ M.map (soundPic cfig w) $ _playingSounds w
--    Cr_status -> drawCrInfo cfig w
--    Mouse_position -> drawMousePosition w
--    Walls_info -> drawWlIDs w
--    Pathing -> drawPathing cfig w
--    Show_path_between -> drawPathBetween w
--    Collision_test -> mempty
--    Circ_collision_test -> mempty
--    Select_creature -> mempty

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

drawPathBetween :: World -> Picture
drawPathBetween w = concat $ do
    sp <- w ^. input . heldWorldPos . at ButtonLeft
    ep <- w ^. input . heldWorldPos . at ButtonRight
    let nodepos = (`getNodePos` w)
        nodelist = makePathBetween sp ep w
    return . 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)

drawWallsNearYou :: World -> Picture
drawWallsNearYou w = concat $ do
    p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos . _xy
    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 =
    foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_wCam w)) w
  where
    f wl =
        setLayer DebugLayer (color rose $ thickLine 3 [a, b])
            <> drawCoord a w
            <> drawCoord b w
      where
        (a, b) = _wlLine wl

drawInspectWalls :: World -> Picture
drawInspectWalls w = concat $ do
    a <- w ^. input . clickPos . at ButtonLeft
    b <- w ^. input . heldPos . at ButtonLeft
    return $
        setLayer DebugLayer (color orange $ line [a, b])
            <> foldMap
                (drawInspectWall w)
                ( filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $
                    IM.elems $ w ^. cWorld . lWorld . walls
                )

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 = concat $ 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 (S.map obstacleColor (_peObstacles pe))

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

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 ^. wCam . camViewFrom

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

drawZoneCirc :: World -> Picture
drawZoneCirc w = concat $ do
    a <- w ^. input . clickWorldPos . at ButtonLeft
    b <- w ^. input . heldWorldPos . at ButtonLeft
    let r = dist a b
        ps = zoneOfCirc 50 a r
    return $
        setLayer DebugLayer (uncurryV translate a $ color red $ circle r)
            <> setLayer DebugLayer (color green $ line [a, b])
            <> foldMap (drawZoneCol orange 50) ps

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

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

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

viewClipBounds :: Config -> 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

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

soundPic :: Config -> World -> Sound -> Picture
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
  where
    p = _soundPos s
    thePic =
        rotate (w ^. wCam . 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 ^. wCam)

drawCoord :: Point2 -> World -> Picture
drawCoord p w =
    setLayer FixedCoordLayer
        . uncurryV translate (worldPosToScreen (w ^. wCam) p)
        . scale 0.1 0.1
        . text
        $ shortPoint2 p

drawWlIDs :: World -> Picture
drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls)
  where
    f wl
        | dist (you w ^. crPos . _xy) (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 ^. wCam) $ 0.5 *.* uncurry (+.+) (_wlLine wl)


drawPathing :: Config -> World -> Picture
drawPathing cfig w =
    setLayer DebugLayer $
        foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _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

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