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 -- }}} fixedCoordPictures :: World -> Picture fixedCoordPictures w = pictures [ scaler $ hudDrawings w , scaler . onLayer MenuLayer $ menuScreen w , setDepth (-1) $ closeObjectTexts w ] where scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w) worldPictures :: World -> Picture worldPictures w = pictures $ concat [ IM.elems $ _decorations w , map _ptPict . IM.elems $ _particles 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 _ptPict' $ _particles' w , map _ptPict' $ _afterParticles' w , map drawWallFloor (wallFloorsToDraw w) -- , map (drawWallFace w) (wallShadowsToDraw w) , map (drawSmokeShadow w) $ _smoke w , testPic w ] testPic :: World -> [Picture] testPic w = [blank] -- [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ] -- $ uncurry translate (mouseWorldPos w) crDraw :: Creature -> Drawing crDraw c = uncurry translate (_crPos c) $ rotate (_crDir c) (_crPict c c) ppDraw :: PressPlate -> Drawing ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) btDraw :: Button -> Drawing btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c) clDraw :: Cloud -> Drawing clDraw c = uncurry translate (_clPos c) $ (_clPict c c) mapWall :: Wall -> Maybe Picture mapWall wl = case _wlSeen wl of False -> Nothing True -> Just $ color c $ polygon [x,x +.+ n2,y +.+ n2, y] where t = 5 *.* errorNormalizeV 68 (y -.- x) n = vNormal t n2 = 4 *.* n (x:y:_) = _wlLine wl c = _wlColor wl 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 drawSmokeShadow :: World -> Smoke -> Picture drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t}) = pictures [ onLayerL [74,0] $ color col $ pictures [uncurry translate p $ circle r' ,line $ (\(x,y) -> [x,y]) $ smokePerpLine (_cameraPos w) p sm ,line [_cameraPos w, mouseWorldPos w] ,trap' p ] , onLayerL [74] $ color (withAlpha 0.1 c) $ pictures $ concatMap (f . (+.+ p)) p's ] where r = r'/2 col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red | otherwise = green orth p' = r *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w) pa p' = p' +.+ orth p' pb p' = p' -.- orth p' pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w) pbo p' = pb p' +.+ l *.* safeNormalizeV (pb p' -.- _cameraCenter w) semiCirc p' = uncurry translate p' $ rotate (0 - (a p')) $ arcSolid 0 180 r a p' = pi - argV (orth p') trap p' = polygon [pa p', pb p', pbo p', pao p'] f p' = [semiCirc p', trap p'] p's = zipWith (\x p -> rotateV (x * fromIntegral t / 60) p) xs ps xs = concat $ repeat [-1,-0.5,0,0.5,1] l = _windowX w + _windowY w + magV (_cameraPos w -.- _cameraCenter w) -- cenpic = color (withAlpha 0.5 c) $ pictures $ f p orth' p' = r' *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w) pa' p' = p' +.+ orth' p' pb' p' = p' -.- orth' p' pao' p' = pa' p' +.+ l *.* safeNormalizeV (pa' p' -.- _cameraCenter w) pbo' p' = pb' p' +.+ l *.* safeNormalizeV (pb' p' -.- _cameraCenter w) trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p'] semiCirc' p' = uncurry translate p' $ rotate (0 - (a p')) $ arcSolid 0 180 r' 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 +.+ _cameraPos 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 = _cameraCenter w sp | pointInPolygon vp sp' = sp' | otherwise = orderPolygon $ (_cameraCenter 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 = _cameraCenter 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 -> Drawing drawItem flIt = uncurry translate (_flItPos flIt) $ rotateDrawing (radToDeg $ _flItRot flIt) (_itFloorPict (_flIt flIt)) ffToDraw :: World -> [ForceField] ffToDraw w = filter (lineOnScreen w . _ffLine) $ IM.elems $ fmap (over ffLine (map (\p->p -.- _cameraPos 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 -.- _cameraPos 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)