module Dodge.Render.ShapePicture ( worldSPic ) where import Dodge.Config.Data --import Dodge.Debug.Picture import Dodge.Picture.SizeInvariant import Dodge.Data import Dodge.Base --import Dodge.Base.Window import Dodge.SoundLogic.LoadSound import Dodge.Graph import Dodge.GameRoom import Dodge.Update.Camera --import Dodge.Zone import Geometry import ShapePicture import Shape import Picture import Sound.Data import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.Map.Strict as M --import Control.Lens --import Data.Maybe worldSPic :: Configuration -> World -> SPic worldSPic cfig w = (extraShapes w, extraPics cfig w) <> foldMap (dbArg _prDraw) (filtOn _pjPos _props) <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures) <> foldMap floorItemSPic (filtOn _flItPos _floorItems) <> foldMap btSPic (filtOn _btPos _buttons) <> foldMap mcSPic (filtOn _mcPos _machines) where filtOn f g = IM.filter (pointIsClose . f) (g w) pointIsClose p = dist camCen p < winSize winSize = 30 + max (_windowX cfig) (_windowY cfig) camCen = _cameraCenter w extraShapes :: World -> Shape extraShapes = _foregroundShape extraPics :: Configuration -> World -> Picture extraPics cfig w = pictures (_decorations w) <> concatMapPic (dbArg _ptDraw) (_particles w) <> concatMapPic (dbArg _lsPict) (_lightSources w) <> testPic w <> concatMapPic clDraw (_clouds w ) <> concatMapPic ppDraw (_pressPlates w ) <> soundPics cfig w <> viewBoundaries cfig w <> drawPathing cfig w -- TODO remove duplicate! testPic :: World -> Picture testPic _ = [] 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) (_itFloorPict (_flIt flit) (_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) soundPics :: Configuration -> World -> Picture soundPics cfig w | _show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w | otherwise = [] 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) drawPathing :: Configuration -> World -> Picture drawPathing cfig w | _debug_pathing cfig = -- 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 :: Configuration -> World -> Picture viewBoundaries cfig w | _debug_view_boundaries cfig = 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) --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