module Dodge.Rendering where -- imports {{{ import Dodge.Data import Dodge.Base --import Dodge.Inventory import Dodge.Rendering.HUD 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 , onLayer InvLayer $ closeObjectTexts w ] where scaler = scale (2 / _windowX w) (2 / _windowY w) menuScreen :: Picture menuScreen = case _menuState w of InGame -> blank LevelMenu x -> pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w tst (-100) 100 0.4 ("LEVEL "++show x) ,controlsList ] PauseMenu -> pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w tst (-100) 100 0.4 "PAUSED" ,tst (-100) 50 0.2 "n - new level" ,tst (-100) 0 0.2 "r - restart" , controlsList ] GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w ,tst (-100) 100 0.4 "GAME OVER" ,tst (-100) 50 0.2 "n - new level" ,tst (-100) 0 0.2 "r - restart" ,controlsList ] where tst x y sc t = translate x y $ scale sc sc $ color white $ text t worldPictures :: World -> Picture worldPictures w = pictures $ concat [ decPicts , ppPicts , itFloorPicts , crPicts , clPicts , buttonPicts , ptPicts , ptPicts' , afterPtPicts' , wlPicts' , wlPicts , smokeShadows , ppLabels , btLabels , testPic w ] where decPicts = IM.elems $ _decorations w ptPicts = map _ptPict (IM.elems (_particles w)) ptPicts' = map _ptPict' $ _particles' w afterPtPicts' = map _ptPict' $ _afterParticles' w buttonPicts = map btDraw (IM.elems (_buttons w)) ppPicts = map ppDraw (IM.elems (_pressPlates w)) crPicts = map crDraw $ IM.elems $ _creatures w clPicts = map clDraw $ IM.elems $ _clouds w smokeShadows = map (drawSmokeShadow w) $ _smoke w wlPicts = map drawWallFloor (wallFloorsToDraw w) wlPicts' = map (drawWallFace w) (wallShadowsToDraw w) itFloorPicts = map drawItem (IM.elems (_floorItems w)) yourPos = _crPos $ you w yourRot = _crDir $ you w yourRad = _crRad $ you w scaler = onLayer LabelLayer . setLayer 1 itLabels = map (scaler . drawItemName w) (IM.elems (_floorItems w)) ppLabels = map (scaler . drawPPText w) (IM.elems (_pressPlates w)) btLabels = map (scaler . drawButText w) (IM.elems (_buttons w)) menuScreen :: Picture menuScreen = case _menuState w of InGame -> blank LevelMenu x -> pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w tst (-100) 100 0.4 ("LEVEL "++show x) ,controlsList ] PauseMenu -> pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w tst (-100) 100 0.4 "PAUSED" ,tst (-100) 50 0.2 "n - new level" ,tst (-100) 0 0.2 "r - restart" , controlsList ] GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w ,tst (-100) 100 0.4 "GAME OVER" ,tst (-100) 50 0.2 "n - new level" ,tst (-100) 0 0.2 "r - restart" ,controlsList ] where tst x y sc t = translate x y $ scale sc sc $ color white $ text t 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) hudDrawings :: World -> Picture hudDrawings w = setLayer 1 $ (onLayer InvLayer) $ pictures [ displayInv 0 w , dShadCol white $ displayHP 0 w , drawCursor (itCol (yourItem w)) w , translate (-390) 20 $ scale 0.05 0.05 $ dShadCol white $ text (_testString w) ] where itCol = fromMaybe (greyN 0.5) . (^? itInvColor) 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) drawCursor :: Color -> World -> Picture drawCursor c w = setLayer 1 $ translate (105-halfWidth w) (halfHeight w - (20* (fromIntegral iPos)) - 20 ) $ lineCol [(( 100,12.5) ,withAlpha 0 c) ,((-100,12.5) ,c) ,((-100,-7.5) ,c) ,(( 100,-7.5) ,withAlpha 0 c) ] where iPos = _crInvSel $ _creatures w IM.! _yourID w controlsList = pictures [tst (-250) (-130) 0.15 "controls:" ,tst (-150) (-130) 0.15 "wasd" ,tst 0 (-130) 0.15 "movement" ,tst (-150) (-160) 0.15 "[rmb]" ,tst 0 (-160) 0.15 "aim" ,tst (-150) (-190) 0.15 "[rmb+lmb]" ,tst 0 (-190) 0.15 "shoot or use item" ,tst (-150) (-220) 0.15 "[wheelscroll]" ,tst 0 (-220) 0.15 "select item" ,tst (-150) (-250) 0.15 "[space]" ,tst 0 (-250) 0.15 "pickup item" ,tst (-150) (-280) 0.15 "f" ,tst 0 (-280) 0.15 "drop item" ,tst (-150) (-310) 0.15 "cp[esc]" ,tst 0 (-310) 0.15 "pause" ,tst (-150) (-340) 0.15 "qe[lmb]" ,tst 0 (-340) 0.15 "rotate camera" ] where tst x y sc t = translate x y $ scale sc sc $ color white $ text t screenBox w = [ (halfWidth w, halfHeight w) , (-halfWidth w, halfHeight w) , (-halfWidth w,-halfHeight w) , ( halfWidth w,-halfHeight w) ] 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 onLayerL [levLayer WlLayer] $ 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 = --IM.elems $ _walls w filter isVisible $ IM.elems -- $ _walls w $ wallsNearZones (zoneOfSight w) w -- should really sort this out where onScreen wall = True -- lineOnScreenCone w (_wlLine wall) isVisible wl | wl ^? blVisible == Just False = False | otherwise = onScreen wl -- 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 = blank | otherwise = colorAndLayer $ polygon $ points where colorAndLayer | _wlIsSeeThrough wall = setLayer 2 . onLayerL [levLayer ShadowLayer,3] . color (withAlpha 0.5 $ _wlColor wall) | otherwise = setLayer 0 . onLayerL [levLayer ShadowLayer,l] . color (_wlColor wall) (x:y:_) = _wlLine wall points = extendConeToScreenEdge w sightFrom (x,y) sightFrom = _cameraCenter w l = case wall of Door {} -> 1 _ -> 2 -- 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) -> intersectSegLineext x y a b) . 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' x y) . makeLoopPairs $ screenPolygon w displayInv :: Int -> World -> Picture displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) (map (\x-> halfHeight w-(20*(fromIntegral x+1))) ns) $ map dItem' is where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----" dItem' i = scale 0.1 0.1 $ dShadCol (_itInvColor i) t where t = text $ _itInvDisplay i i displayAmount :: Int -> String displayAmount n | n > 1 = "-x" ++show n | otherwise = [] 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)) drawButText :: World -> Button -> Picture drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100 && hasLOS (_btPos bt) (_crPos (you w)) w && _btState bt /= BtNoLabel = pictures [ tranItPos' $ line [(-8,10),(-15,10),(-15,-10),(-8,-10)] , tranItPos' $ line [( 8,10),( 15,10),( 15,-10),( 8,-10)] ] | otherwise = blank where tranItPos' = uncurry translate (_btPos bt) . rotate (_cameraRot w) t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w)) . rotate (_cameraRot w) zoom = _cameraZoom w drawPPText :: World -> PressPlate -> Picture drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100 && hasLOS (_ppPos pp) (_crPos (you w)) w = t $ rotate (_cameraRot w) $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)] , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)] ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white $ scale 0.1 0.1 $ text $ _ppText pp ] | otherwise = blank where t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_ppPos pp -.- _cameraPos w)) zoom = _cameraZoom w scLine = dShadCol white . line . fmap (sqrt zoom *.*) drawItemName :: World -> FloorItem -> Picture drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100 && hasLOS (_flItPos flIt) (_crPos (you w)) w = pictures [ tranItPos' $ line [(-8,10),(-15,10),(-15,-10),(-8,-10)] , tranItPos' $ line [( 8,10),( 15,10),( 15,-10),( 8,-10)] ] | otherwise = blank where tranItPos' = uncurry translate (_flItPos flIt) . rotate (_cameraRot w) t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w)) . rotate (_cameraRot w) nameOfItem = _itName $ _flIt flIt zoom = _cameraZoom w dShadCol :: Color -> Picture -> Picture dShadCol c p = pictures $ [ color black $ uncurry translate (1.2,-1.2) p , color c p ] 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] displayHP :: Int -> World -> Picture displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $ scale 0.2 0.2 $ text $ reverse $ take 5 $ (++ repeat ' ') $ reverse $ show $ _crHP $ _creatures w IM.! n wallsForGloom :: World -> [((Point2,Point2),Point4)] wallsForGloom 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) 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)