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 $ onLayer LabelLayer $ pictures [ppLabels, btLabels] [ scaler $ hudDrawings w , scaler $ onLayer MenuLayer menuScreen --, onLayer InvLayer $ activeObjectText w , 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 , wallShadows , smokeShadows -- , itLabels , 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 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 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 = [setLayer 1 $ onLayerL [99] $ color red $ bezierQuad (-200,200) (-200,-200) (200,200) ] -- $ 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 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 (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c}) = onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps drawWall wl = case _wlDraw wl of -- Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon $ _wlLine wl 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 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 = colorAndLayer $ polygon $ points where colorAndLayer | _wlIsSeeThrough wall = setLayer 2 . onLayerL [levLayer ShadowLayer] . color (withAlpha 0.2 $ _wlColor wall) | otherwise = setLayer 1 . onLayerL [levLayer ShadowLayer,2] . color black (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 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 (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 (FlAm {_flItPos = p}) = uncurry translate p $ onLayer FlItLayer $ rectangleSolid 5 5 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 --[ scale (2/_windowX w) (2/_windowY w) -- . t -- . translate (-15) (-10*sqrt zoom - 5) $ dShadCol white -- $ scale 0.1 0.1 $ text $ _btText bt [ 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 --[ scale (2/_windowX w) (2/_windowY w) -- . t -- . translate (-15) (-10*sqrt zoom - 5) $ dShadCol white -- $ scale 0.1 0.1 $ text $ nameOfItem [ 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 = case flIt of FlIt {} -> _itName $ _flIt flIt FlAm {_flAm = PistolBullet} -> "Bullets" FlAm {_flAm = LiquidFuel} -> "Liquid Fuel" zoom = _cameraZoom w 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 $ [ 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,Point2,Point2)] wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough) $ filter wallCastsShadow $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where linePairs (x:y:z:w:_) = (x,y,z,w) linePairs (x:y:_) = (x,y,x,y) wallCastsShadow wl = case wl ^? wlCastShadow of Just b -> b Nothing -> True --(AutoDoor {_wlCastShadow = b}) = b -- wallCastsShadow _ = True wallsForGloom' :: World -> [(Point2,Point2)] wallsForGloom' w = map (wallPairBack . _wlLine) $ filter (not . _wlIsSeeThrough) $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w -- where wallPairBack (x:y:_) = (ss $ x +.+ n,ss $ y+.+ n) where wallPairBack (x:y:_) = (x +.+ n,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 --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