module Dodge.Rendering where -- imports {{{ import Dodge.Data import Dodge.Base --import Dodge.Inventory import Dodge.Rendering.HUD import Dodge.Rendering.MenuScreen import Geometry import Picture import Data.Graph.Inductive.Query.DFS import Data.Graph.Inductive.Graph import Control.Monad.State import Data.List import Data.Bifunctor import Data.Function import Control.Applicative import Control.Lens import Data.Maybe import qualified Data.IntMap.Strict as IM import qualified Data.Map as M import qualified Data.Set as S worldPictures :: World -> Picture worldPictures w = pictures $ concat [ IM.elems $ _decorations w , map _ptPict . IM.elems $ _projectiles w , map drawItem . IM.elems $ _floorItems w , map crDraw . IM.elems $ _creatures w , map clDraw . IM.elems $ _clouds w , map btDraw (IM.elems (_buttons w)) , map (\pt -> _ptDraw pt pt) $ _particles' w , map drawWallFloor (wallFloorsToDraw w) , testPic w ] fixedCoordPictures :: World -> Picture fixedCoordPictures w = pictures [ hudDrawings w , scaler . onLayer MenuLayer $ menuScreen w , customMouseCursor w ] where scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w) customMouseCursor :: World -> Picture customMouseCursor w = setDepth (-1) . scale (2 /_windowX w) (2/ _windowY w) . uncurry translate (_mousePos w) $ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ] testPic :: World -> [Picture] testPic w = [blank] crDraw :: Creature -> Picture crDraw c = uncurry translate (_crPos c) $ rotate (_crDir c) (_crPict c c) ppDraw :: PressPlate -> Picture ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) btDraw :: Button -> Picture btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c) clDraw :: Cloud -> Picture clDraw c = uncurry translate (_clPos c) $ (_clPict c c) wallFloorsToDraw :: World -> [Wall] wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w where onScreen wall = lineOnScreen w (_wlLine wall) isVisible wl | wl ^? blVisible == Just False = False | otherwise = onScreen wl wallsOnScreen :: World -> IM.IntMap Wall wallsOnScreen w = wallsNearZones (zoneOfScreen w) w 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 (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering" errorNormalizeVDR p = normalizeV p printPoint :: Point2 -> Picture printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)] printRotPoint :: Float -> Point2 -> Picture printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3 , rotate (0 - 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 scTran p = p +.+ _cameraCenter w tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w) tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w) br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w)) bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w)) x = halfWidth w + 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] -> Bool lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 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] -> Bool lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 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 x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)] drawItem :: FloorItem -> Picture drawItem flIt = uncurry translate (_flItPos flIt) $ rotate (_flItRot flIt) (_itFloorPict (_flIt flIt)) ffToDraw :: World -> [ForceField] ffToDraw w = filter (lineOnScreen w . _ffLine) $ IM.elems $ fmap (over ffLine (map (\p->p -.- _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 p = rotateV (-_cameraRot w) $ ypShift 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:[]) fCol = color (_ffColor ff) col = _ffColor ff ypShift = yp -.- _cameraCenter w youOnFF = circOnLine' 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] wallsPointsAndCols :: World -> [((Point2,Point2),Point4)] wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where linePairs (x:y:_) = (x,y) f wl = (linePairs $ _wlLine wl, _wlColor wl) wallsWindows :: World -> [((Point2,Point2),Point4)] wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) . filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where linePairs (x:y:_) = (x,y) f wl = (linePairs $ _wlLine wl, _wlColor wl) wallsForShadows :: World -> [(Point2,Point2)] wallsForShadows w = map (linePairs . _wlLine) . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where linePairs (x:y:_) = (x,y) lightsForGloom' :: World -> [(Point4)] lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w) where getLS ls = ( fst $ _lsPos ls, snd $ _lsPos ls, _lsRad ls , _lsIntensity ls) getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos ls, _tlsRad ls, _tlsIntensity ls)