loop/src/Dodge/Render/Picture.hs

--{-# LANGUAGE TupleSections #-}
module Dodge.Render.Picture
    ( worldPictures
    , wallsAndWindows
    , lightsForGloom
    , fixedCoordPictures
    ) where
import Dodge.Data
--import Dodge.Update.Camera
--import Dodge.GameRoom
import Dodge.Base
import Dodge.Base.Window
import Dodge.Zone
import Dodge.Graph
import Dodge.Picture.SizeInvariant
import Dodge.Picture.Layer
import Dodge.Render.HUD
import Dodge.Render.MenuScreen
import Dodge.Render.ShapePicture
import Dodge.SoundLogic.LoadSound
import Dodge.Config.Data
import Dodge.GameRoom
import Dodge.Update.Camera
import Sound.Data
import Geometry
import Picture
import ShapePicture

import Control.Lens
import Data.Maybe
import Data.List (partition)
import qualified Data.IntMap.Lazy as IM
import qualified Data.Map as M

worldPictures :: World -> Picture
worldPictures w = pictures
    [pictures (_decorations w)
    ,concatMapPic (_spPicture . dbArg _prDraw)  $ _props w
    ,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w
    ,concatMapPic (dbArg _ptDraw) $ _particles w
    ,concatMapPic (dbArg _lsPict) $ _lightSources w
    ,testPic w
    ,concatMapPic (_spPicture . floorItemSPic) $ _floorItems w
    ,concatMapPic clDraw $ _clouds w      
    ,concatMapPic ppDraw $ _pressPlates w
    ,concatMapPic btDraw $ _buttons w
    ,concatMapPic drawWallFloor $ wallFloorsToDraw w
    ,soundPics w
    ,viewBoundaries w
    ,drawPathing w
    ]
  where
    crIsClose cr = dist (_crPos cr) camCen < winSize
    winSize = 30 + max (getWindowX w) (getWindowY w)
    camCen = _cameraCenter w

fixedCoordPictures :: World -> Picture
fixedCoordPictures w = case _menuLayers w of 
    [] -> pictures
        [ hudDrawings w
        , customMouseCursor w
        ]
    (lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay
  where 
    scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)

customMouseCursor :: World -> Picture
customMouseCursor w = 
    scale (2 /getWindowX w) (2/ getWindowY w) 
    . uncurryV translate (_mousePos w)
    . color white
    $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]

testPic :: World -> Picture
testPic _ = []

drawPathing :: World -> Picture
drawPathing w
    | _debug_pathing (_config w) 
        = -- setLayer 5 $ 
        (color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr)
        <> concatMap dispInc (graphToIncidence gr)
    | otherwise = []
  where
    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
    gr = _pathGraph w
viewBoundaries :: World -> Picture
viewBoundaries w
    | _debug_view_boundaries (_config w) 
        = setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
        <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
    | otherwise = []
  where
    p = _crPos $ you w
    grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)

soundPics :: World -> Picture
soundPics w 
    | _show_sound (_config w) = pictures $ M.map (soundPic w) $ _playingSounds w
    | otherwise = []

soundPic :: World -> Sound -> Picture
soundPic w s = fixedSizePicClampArrow 50 50 thePic p 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)

crDraw :: World -> Creature -> Picture
crDraw w c = _spPicture $ _crPict c c w
ppDraw :: PressPlate -> Picture
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
btDraw :: Button -> Picture
btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_spPicture $ _btPict c c)

clDraw :: Cloud -> Picture
clDraw c = translate3 (_clPos c) (_clPict c c)

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 _wlIsSeeThrough wl
    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

wallsAndWindows
    :: World
    -> ( [((Point2,Point2),Point4)]  ,[((Point2,Point2),Point4)] )
wallsAndWindows w
    = (map f wls, map f wins)
  where
    f wl = (_wlLine wl, _wlColor wl)
    (wins,wls) = partition _wlIsSeeThrough . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w

lightsForGloom :: World -> [(Point3,Float,Point3)]
lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTLS (_tempLightSources w)
  where 
    getLS ls  
        | dist campos (fst2 $ _lsPos ls) > 1000 = Nothing
        | otherwise = Just ( _lsPos ls,  _lsRad ls^(2::Int) , _lsIntensity ls)
    getTLS ls 
        | dist campos (fst2 $ _tlsPos ls) > 1000 = Nothing
        | otherwise = Just ( _tlsPos ls, _tlsRad ls^(2::Int), _tlsIntensity ls)
    campos = _cameraCenter w
    fst2 (V3 a b _) = V2 a b