module Dodge.Render.ShapePicture
    ( worldSPic
    ) where
import Dodge.Creature.Picture.Awareness
import Dodge.ShortShow
import Dodge.Config.Data
import Dodge.Render.InfoBox
import Dodge.Debug.Picture
import Dodge.Picture.SizeInvariant
import Dodge.Data
import Dodge.Zone
import Dodge.Base
--import Dodge.Base.Window
import Dodge.SoundLogic.LoadSound
import Dodge.Graph
import Dodge.GameRoom
import Dodge.Update.Camera
import Dodge.Item.Draw
import Dodge.Render.List
import Dodge.Path
--import Dodge.Zone
import Geometry
import Geometry.Zone
import ShapePicture
import Picture
import Sound.Data
import Geometry.ConvexPoly
import ShortShow
import Shape.Data
--import Dodge.Base.Collide

--import Data.Foldable
import qualified Data.IntMap.Strict as IM -- Lazy?
import qualified Data.Map.Strict as M
--import qualified Data.Set as Set
import Control.Lens
import Data.Maybe
import qualified Streaming.Prelude as S
import Streaming
import qualified Data.Graph.Inductive as FGL
import qualified Data.Set as Set
import Padding
--import Data.Foldable

-- TODO only filter out shapes outside the range of the furthest shown light source
worldSPic :: Configuration -> World -> SPic
worldSPic cfig w 
    =  ((mempty, extraPics cfig w)                                                  )
    <> (foldMap (dbArg _prDraw) (filtOn _prPos _props)                              )
    <> (foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)           )
    <> (foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)   )
    <> (foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)                            )
    <> (foldMap (dbArg _crPict) (filtOn _crPos _creatures)                          )
    <> (foldMap floorItemSPic (filtOn _flItPos _floorItems)                         )
    <> (foldMap btSPic (filtOn _btPos _buttons)                                     )
    <> (foldMap mcSPic (filtOn _mcPos _machines)                                    )
    <> (anyTargeting cfig w                                                         )
  where
    filtOn f g = IM.filter (pointIsClose . f) (g w)
    pointIsClose = cullPoint cfig w

type SPicStream = Stream (Of ShapeObj) (Stream (Of Verx) IO) ()

anyTargeting :: Configuration -> World -> SPic
anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
  where
    cr = you w
    f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw)

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

cullPoint :: Configuration -> World -> Point2 -> Bool
cullPoint cfig w p 
    | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)
    | otherwise = dist (_cameraCenter w) p < _viewDistance w

extraPics :: Configuration -> World -> Picture
extraPics cfig w = pictures (_decorations w)
    <> concatMapPic (dbArg _ptDraw) (_particles    w)
    <> concatMapPic (dbArg _bmDraw) (_positronBeams $ _beams w)
    <> concatMapPic (dbArg _bmDraw) (_electronBeams $ _beams w)
    <> concatMapPic (dbArg _lsPict) (_lightSources w)
    <> testPic cfig w
    <> concatMapPic clDraw (_clouds w      )
    <> concatMapPic ppDraw (_pressPlates w )
    <> viewClipBounds cfig w
    <> debugDraw cfig w

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
    (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig)

debugDraw' :: Configuration -> World -> DebugBool -> ([String],Picture)
{-# INLINE debugDraw' #-}
debugDraw' cfig w bl = case bl of
    Show_debug  -> lstring "Show debug"
    Noclip      -> lstring "Noclip"
    Remove_LOS  -> lstring "No line of sight"
    Cull_more_lights    -> lstring "Cull more lights"
    Close_shape_culling -> lstring "Close shape culling"
    Bound_box_screen    -> lstring "bound box screen, this should be moved"
    Show_ms_frame           -> rdraw mempty
    View_boundaries         -> rdraw $ viewBoundaries w
    Show_bound_box          -> rdraw $ drawBoundingBox w
    Show_wall_search_rays   -> rdraw $ drawWallSearchRays w
    Show_dda_test           -> rdraw $ drawDDATest w
    Show_far_wall_detect    -> rdraw $ drawFarWallDetect w
    Show_select             -> rdraw $ drawWorldSelect w
    Inspect_wall            -> rdraw $ drawInspectWalls w
    Cr_awareness            -> rdraw $ drawCreatureDisplayTexts w
    Show_sound              -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
    Cr_status               -> rdraw $ drawCrInfo cfig w
    Mouse_position          -> rdraw $ drawMousePosition cfig w
    Walls_info              -> rdraw $ drawWlIDs cfig w
    Pathing                 -> rdraw $ drawPathing cfig w
    Show_nodes_near_select  -> rdraw $ drawNodesNearSelect w
    Show_path_between       -> rdraw $ drawPathBetween w
  where
    lstring str = ([str],mempty)
    rdraw   pic = (mempty,pic)

drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)

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 w
    ep = _rSelect w

drawNodesNearSelect :: World -> Picture
drawNodesNearSelect w = setLayer DebugLayer $
     runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
--    <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
    <> color green (drawCross sp)
--    <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
  where
    sp = _lSelect w

drawInspectWalls :: World -> Picture
drawInspectWalls w = foldMap (drawInspectWall w) 
    $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
    $ IM.elems $ _walls w
  where
    (a,b) = _lLine w

drawInspectWall :: World -> Wall -> Picture
drawInspectWall w wl = setLayer DebugLayer $ 
        color rose (thickLine 3 [a,b])
--    <> foldMap (drawZone wlZoneSize)
--        (runIdentity $ S.toList_ $ zoneOfWall wlZoneSize wl)  -- this won't work if wlZoneSize is not consistent
    <> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
  where
    (a,b) = _wlLine wl 

drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = fromMaybe mempty $ do
    paths <- w ^? doors . ix drid . drObstructs
    return $ foldMap (drawPathEdge . (^. _3)) 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 w
    (c,d) = _rLine w

drawFarWallDetect :: World -> Picture
drawFarWallDetect w = setLayer DebugLayer 
    . color yellow 
    . foldMap (\q -> line 
        [ p
        , fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg p q w
        ]   )
    $ runIdentity $ S.toList_ $ streamViewpoints p w
  where
    p = _cameraViewFrom w

drawDDATest :: World -> Picture
drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps)
    <> runIdentity (S.foldMap_ (drawZone' 50) ps')
    <> runIdentity (S.foldMap_ drawCross qs)
    <> color blue (runIdentity (S.foldMap_ drawCross qs'))
    <> setLayer DebugLayer (color yellow (line [cvf,mwp]))
  where
    cvf = _cameraViewFrom w
    mwp = mouseWorldPos w
    ps = ddaStreamX 50 cvf mwp
    ps' = ddaStreamY 50 (_cameraViewFrom w) (mouseWorldPos w)
    qs = xIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
    qs' = yIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)

drawCross :: Point2 -> Picture
drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5

crossPic :: Float -> Picture
crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]

drawZone :: Float -> V2 Int -> Picture
drawZone s (V2 x y) = setLayer DebugLayer . color orange $ 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)]

drawZone' :: Float -> V2 Int -> Picture
drawZone' s (V2 x y) = setLayer DebugLayer . color green $ line (p:ps ++ [p])
  where
    (p:ps) = zipWith (+.+) (map (2*.*) 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 = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w
  where
    f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
        <> line [_cameraViewFrom w, p]

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

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

clDraw :: Cloud -> Picture
clDraw c = translate3 (_clPos c) (_clPict c c)
ppDraw :: PressPlate -> Picture
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)

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

btSPic :: Button -> SPic
btSPic bt = uncurryV translateSPf (_btPos bt)
    $ rotateSP (_btRot bt) (_btPict bt bt)
mcSPic :: Machine -> SPic
mcSPic bt = uncurryV translateSPf (_mcPos bt)
    $ rotateSP (_mcDir bt) (_mcDraw bt bt)

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

drawMousePosition :: Configuration -> World -> Picture
drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
    . uncurryV translate p
    . scale 0.1 0.1
    . text 
    $ shortPoint2 mwp 
  where
    p = worldPosToScreen w mwp
    mwp = mouseWorldPos w

drawWlIDs :: Configuration -> World -> Picture
drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
  where
    f wl 
        | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty  -- this should be improved with a better "on screen test"
        | otherwise = winScale cfig
            . uncurryV translate p
            . scale 0.1 0.1
            . text 
            $ show $ _wlID wl 
      where
        p = worldPosToScreen w $ 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) . (^?! _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 = _pathGraph w

crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
crDisplayInfo cfig w 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 w $ _crPos cr

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

drawCrInfo :: Configuration -> World -> Picture
drawCrInfo cfig w = setLayer FixedCoordLayer 
        $ renderInfoListsAt (2*hw - 400) 0 cfig w
        $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
  where
    hw = halfWidth cfig

viewBoundaries :: World -> Picture
viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _grBound) grs)
    <> color yellow (foldMap (\q -> line [p,q]) $ farWallPoints p w)
  where
    p = _crPos $ you w
    grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)

viewClipBounds :: Configuration -> World -> Picture
viewClipBounds cfig w
    | _debug_view_clip_bounds cfig == AllRoomClipBoundaries
         = setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping w)
    | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
        = setLayer DebugLayer $ f (_roomClipping 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

--wallFloorsToDraw :: World -> [Wall]
--wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
--  where 
--    onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall
--    isVisible wl 
--        | wl ^? wlDraw == Just False = False
--        | otherwise = onScreen wl
--
--lineOnScreen :: World -> Point2 -> Point2 -> Bool
--lineOnScreen w p1 p2 = pointInPolygon p1 sp 
--    || pointInPolygon p2 sp 
--    || any (isJust . uncurry (intersectSegSeg p1 p2)) sps
--  where 
--    sp = screenPolygon w
--    sps = zip sp (tail sp ++ [head sp])
--
--drawWallFloor :: Wall -> Picture
--drawWallFloor wl = if _wlOpacity wl == SeeThrough
--    then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
--    else blank
--  where 
--    (x,y) = _wlLine wl
--    c = _wlColor wl
--    n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
--
--errorNormalizeVDR :: Point2 -> Point2
--errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
--errorNormalizeVDR p = normalizeV p
