--{-# LANGUAGE TupleSections #-} module Dodge.Render.Picture 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 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 ^? blVisible == Just False = False | otherwise = onScreen wl 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 printPoint :: Point2 -> Picture printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)] printRotPoint :: Float -> Point2 -> Picture printRotPoint r p = color white . uncurryV translate p $ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)] outsideScreenPolygon :: World -> [Point2] outsideScreenPolygon w = [tr,tl,bl,br] where scRot = rotateV (_cameraRot w) scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p | otherwise = error "Trying to set screen zoom to zero" scTran p = p +.+ _cameraCenter w tr = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) ( 3* halfHeight w) tl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) ( 3* halfHeight w) br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w)) bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w)) wallShadowsToDraw :: World -> [Wall] wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible)) . IM.elems $ wallsNearZones (zoneOfSight w) w -- cannot only test if walls are on screen, but also if they are on the cone -- towards the center of sight lineOnScreenCone :: World -> Point2 -> Point2 -> Bool lineOnScreenCone w p1 p2 = pointInPolygon p1 sp || pointInPolygon p2 sp || any (isJust . uncurry (intersectSegSeg p1 p2)) sps where sp' = screenPolygon w vp = _cameraViewFrom w sp | pointInPolygon vp sp' = sp' | otherwise = orderPolygon (_cameraViewFrom w : sp') sps = zip sp (tail sp ++ [head sp]) 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]) drawWallFace :: World -> Wall -> Picture drawWallFace w wall | isRHS sightFrom x y || _wlIsSeeThrough wall = blank | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points where (x,y) = _wlLine wall points = extendConeToScreenEdge w sightFrom (x,y) sightFrom = _cameraViewFrom w -- 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 :: World -> Point2 -> Point2 -> Maybe Point2 intersectLinefromScreen w a b = listToMaybe . mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a)) . makeLoopPairs $ screenPolygon w extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2] extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y] cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x)) . makeLoopPairs $ screenPolygon w rectangleSolid :: Float -> Float -> Picture rectangleSolid x y = polygon $ map toV2 [(x,y),(x,-y),(-x,-y),(-x,y)] ffToDraw :: World -> [ForceField] ffToDraw _ = [] -- filter (lineOnScreen w . _ffLine) $ -- IM.elems $ over ffLine (map ( -.- _cameraCenter w)) <$> -- _forceFields w drawFF :: ForceField -> Picture drawFF FF{_ffLine = l, _ffColor = col} = pictures [color white $ line l , color col $ lineOfThickness 6 l ] drawFFShadow :: World -> ForceField -> [Picture] drawFFShadow w ff | youOnFF = [] | otherwise = map (rotate ( _cameraRot w) . pane) [0,0.05..0.25] where x = rotateV (-_cameraRot w) x' y = rotateV (-_cameraRot w) y' yp = _crPos $ you w (x1:y1:_) = _ffLine ff (x':y':_) | isRHS x1 y1 yp = [y1,x1] | otherwise = [x1,y1] col = _ffColor ff ypShift = yp -.- _cameraCenter w youOnFF = circOnSeg x' y' ypShift (_crRad $ you w) pane j = color (withAlpha 0.1 col) $ polygon [ x , x +.+ ((0.1 + j) *.* (x -.- ypShift)) , y +.+ ((0.1 + j) *.* (y -.- ypShift)) , y] wallsAndWindows :: World -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] ) wallsAndWindows w = (map f wls, map f $ filter (fromMaybe True . (^? blVisible)) wins) where f wl = (_wlLine wl, _wlColor wl) (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w --(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsOnScreen w wallsToList :: [((Point2,Point2),Point4)] -> [Float] wallsToList = concatMap (\((V2 a b,V2 c d),V4 e f g h) -> [a,b,c,d,e,f,g,h]) 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