module Dodge.Rendering where -- imports {{{ import Dodge.Data import Dodge.Base 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 -- }}} -- drawTest :: World -> Picture drawTest w = screenT $ color red $ circle 200 where (x,y) = (_windowX w,_windowY w) screenT = scale (1/x) (1/y) draw' :: Picture -> World -> ([((Float,Float),(Float,Float))] ,[((Float,Float),Float,Float)] ,Picture,Picture) draw' p w = (\(x,y) -> (wallsForGloom w,lightsForGloom w,x,y)) (draw'' p w) draw :: Picture -> World -> Picture draw p w = (\(x,y) -> f $ pictures [x,y]) $ draw'' p w where f = scale (2/_windowX w) (2/_windowY w) draw'' :: Picture -> World -> (Picture , Picture) draw'' b w-- | (Char 'm') `S.member` _keys w -- = let a = (-500,30) -- b = (200,0) -- in pictures [ color white $ polygon screenBox -- , color blue $ circleSolid 40 -- , line [a,b] -- , uncurry translate (ssaTriPoint a (0,0) b 40) -- $ color red $ circleSolid 5 -- ] = case _mapDisplay w of (True, z) -> (blank ,pictures [color white $ circleSolid 3 ,scale z z $ rotate (0 - (_cameraRot w)) $ uncurry translate ((0,0) -.- _cameraCenter w) $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w] ) _ -> ( blank --,pictures $ map fst pics ,collectDrawings w ) -- ++ map screenShift (pathsTest ++ map drawNode (labNodes $ _pathGraph w)) where yourPos = _crPos $ you w backgroundTile = [screenShift $ translate (5*512*x) (5*512*y) $ scale 5 5 b | x <- [x1..x2] , y <- [y1..y2] ] where (x',y') = yourPos (x'',y'') = (fromIntegral $ round (x'/(512*5)), fromIntegral $ round (y'/(512*5))) x1 = (x''-1) x2 = (x''+1) y1 = (y''-1) y2 = (y''+1) screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) ) . uncurry translate ((0,0) -.- _cameraPos w) zoom = _cameraZoom w pathsTest = map drawPair $ _pathGraph' w drawPair (x,y) = color cyan $ pictures [line [x,y] -- , uncurry translate x $ scale 0.05 0.05 $ text $ show x ] drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i collectDrawings :: World -> Picture collectDrawings w = pictures [screenShift $ pictures $ concat [ decPicts , ppPicts , itFloorPicts , crPicts , clPicts , buttonPicts , ptPicts , ptPicts' , afterPtPicts' , wlPicts , wallShadows , smokeShadows ] , onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels] , hudDrawings w , onLayer MenuLayer menuScreen ] -- <> [onLayer GloomLayer $ theLighting w] where screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) ) . uncurry translate ((0,0) -.- _cameraPos w) zoom = _cameraZoom w 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 wallShadows = map (drawWallShadow w) $ wallShadowsToDraw w smokeShadows = map (drawSmokeShadow w) $ _smoke w wlPicts = map drawWall (wallsToDraw w) itFloorPicts = map (drawItem) (IM.elems (_floorItems w)) yourPos = _crPos $ you w yourRot = _crDir $ you w yourRad = _crRad $ you w -- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w))) -- (map (_itFloorPict . _flIt) (IM.elems (_floorItems w))) itLabels = pictures $ map (drawItemName w) (IM.elems (_floorItems w)) ppLabels = pictures $ map (drawPPText w) (IM.elems (_pressPlates w)) btLabels = pictures $ map (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 hudDrawings :: World -> Picture hudDrawings w = (onLayer InvLayer) $ pictures [ displayInv 0 w , dShadCol white $ displayHP 0 w , --color (itCol (yourItem w)) color white $ drawCursor 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 :: World -> Picture drawCursor w = translate (105-halfWidth w) (halfHeight w - (25* (fromIntegral iPos)) - 20 ) $ setLayer 2 $ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)] 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 wallsToDraw :: World -> [Wall] wallsToDraw 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' drawWall :: Wall -> Drawing drawWall wl = case _wlDraw wl of Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y] Just d -> d wl where (x:y:_) = _wlLine wl c = _wlColor wl t = 5 *.* errorNormalizeVDR (y -.- x) n = vNormal t n2 = 3 *.* n layer2 | _wlIsSeeThrough wl = 0 | isJust $ wl ^? doorMech = 1 | otherwise = 2 -- wallOrdering wl = (not $ _wlIsSeeThrough wl, not $ isJust $ wl ^? doorMech) 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 -- wallShadowsToDrawOnScreen :: World -> [Wall] -- wallShadowsToDrawOnScreen w = --IM.elems $ _walls w -- sortBy (compare `on` not . _wlIsSeeThrough) $ filter isVisible $ IM.elems -- $ _walls w -- -- $ wallsOnScreen w -- -- should really sort this out -- where onScreen wall = lineOnScreen w (_wlLine wall) -- isVisible wl | wl ^? blVisible == Just False = False -- | otherwise = onScreen wl 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]) drawWallShadow :: World -> Wall -> Drawing drawWallShadow w wall | isRHS sightFrom x y = blank | otherwise = onLayerL l $ color shadCol $ polygon $ points where l | _wlIsSeeThrough wall = [levLayer ShadowLayer] | otherwise = [levLayer ShadowLayer, 0] (x:y:_) = _wlLine wall ps = linePointsBetween x y ds = map (\p -> safeNormalizeV (p -.- sightFrom)) ps p's = zipWith (\d x -> (15 *.* d) +.+ x) ds ps sightFrom = _cameraCenter w shadCol = if _wlIsSeeThrough wall then withAlpha 0.2 $ _wlColor wall else black corns = screenPolygon w borders = filter g $ zip corns (tail corns ++ [head corns]) g (a,b) = isLHS a b sightFrom borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders shadowedCorners = filter isShadowed coneTop isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's) f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's) points = orderPolygon (borderps ++ p's) linePointsBetween :: Point2 -> Point2 -> [Point2] linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n-1] ++ [p'] | otherwise = [p,p'] where d = dist p p' n = ceiling $ d / 50 p'' = (1/fromIntegral n) *.* (p' -.- p) displayInv :: Int -> World -> Picture displayInv n w = pictures $ zipWith (translate (10-halfWidth w)) (map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n dItem' NoItem = scale 0.15 0.15 $ dShadCol (greyN 0.5) $ text "----" dItem' i = scale 0.15 0.15 $ pictures [dropShadow t, color (_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 (FlAm {_flItPos = p}) = uncurry translateDrawing p $ onLayer FlItLayer $ rectangleSolid 5 5 drawItem flIt = uncurry translateDrawing (_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 = 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 $ _btText bt ] | otherwise = blank where t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w)) zoom = _cameraZoom w scLine = dShadCol white . line . fmap (sqrt zoom *.*) 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 = 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 $ nameOfItem ] | otherwise = blank where t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w)) nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt FlAm {_flAm = PistolBullet} -> "Bullets" FlAm {_flAm = LiquidFuel} -> "Liquid Fuel" zoom = _cameraZoom w scLine = dShadCol white . line . fmap (sqrt zoom *.*) ringPict :: Drawing ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10),(-15,-10),(-8,-10)] ,line [( 8,10),( 15,10),( 15,-10),( 8,-10)] ] dShadCol :: Color -> Picture -> Picture dShadCol c p = pictures $ map (flip (uncurry translate) p) [(0.2,-0.2) ,(0.4,-0.4) ,(0.6,-0.6) ,(0.8,-0.8) ,( 1,- 1) ,(1.2,-1.2) ] ++ [color c p] dropShadow :: Picture -> Picture dropShadow p = pictures [ translate 5 (-5) p , translate 1 (-1) p , translate 2 (-2) p , translate 3 (-3) p , translate 4 (-4) p , translate 6 (-6) p , translate 7 (-7) p , translate 8 (-8) p , translate 9 (-9) 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-70) (halfHeight w-40) $ scale 0.2 0.2 $ text $ show $ _crHP $ _creatures w IM.! n testPic w = blank wallsForGloom :: World -> [(Point2,Point2)] wallsForGloom w = map (\(x:y:_) -> (screenShift x,screenShift y)) $ map _wlLine $ filter (not . _wlIsSeeThrough) $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w) zoom = _cameraZoom w wallsForGloom' :: World -> [(Point2,Point2,Point2,Point2)] wallsForGloom' w = map (wallPairToFour . _wlLine) $ filter (not . _wlIsSeeThrough) $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where wallPairToFour (x:y:_) = (ss x,ss y,ss $ x +.+ n,ss $ y+.+ n) where n = 15 *.* (normalizeV $ vNormal $ y -.- x) ss' v = rotateV (0 - _cameraRot w) (v -.- _cameraPos w) ss'' (a,b) = (a*2*zoom / _windowX w,b*2*zoom / _windowY w) ss = ss'' . ss' -- the ss transformation would possibly be better done using a matrix in the -- shader zoom = _cameraZoom w lightsForGloom' :: World -> [(Point4)] lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w) where getLS ls = ( fst $ ssls ls, snd $ ssls ls, _lsRad ls , _lsIntensity ls) getTLS ls = ( fst $ sstls ls,snd $ sstls ls, _tlsRad ls, _tlsIntensity ls) ss' v = rotateV (0 - _cameraRot w) (v -.- _cameraPos w) ss'' (a,b) = (a*2*zoom / _windowX w,b*2*zoom / _windowY w) ss = ss'' . ss' ssls = ss . _lsPos sstls = ss . _tlsPos zoom = _cameraZoom w lightsForGloom :: World -> [(Point2,Float,Float)] lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w) where getLS ls = (screenShift $ _lsPos ls, _lsRad ls * zoom, _lsIntensity ls) getTLS ls = (screenShift $ _tlsPos ls, _tlsRad ls * zoom, _tlsIntensity ls) screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w) zoom = _cameraZoom w