diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index 6ef26d65c..cf7f0eb23 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -5,6 +5,7 @@ import Dodge.Base --import Dodge.Inventory import Dodge.Rendering.HUD +import Dodge.Rendering.MenuScreen import Geometry import Picture @@ -28,93 +29,26 @@ import qualified Data.Set as S fixedCoordPictures :: World -> Picture fixedCoordPictures w = pictures [ scaler $ hudDrawings w - , scaler $ onLayer MenuLayer menuScreen + , scaler . onLayer MenuLayer $ menuScreen w , setDepth (-1) $ closeObjectTexts w ] where scaler = setDepth (-1) . 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 - , map (color $ withAlpha 0 black) wlPicts' - , smokeShadows - , ppLabels - , btLabels + = 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 ] - 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 (drawWallFace w) (wallShadowsToDraw w) - wlPicts = map drawWallFloor (wallFloorsToDraw 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] @@ -122,17 +56,6 @@ testPic w = [blank] -- $ 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 @@ -143,44 +66,6 @@ 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 = @@ -271,13 +156,9 @@ outsideScreenPolygon w = [tr,tl,bl,br] x = halfWidth w + halfHeight w wallShadowsToDraw :: World -> [Wall] -wallShadowsToDraw w = filter isVisible +wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible)) . IM.elems $ 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 @@ -300,7 +181,7 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 drawWallFace :: World -> Wall -> Picture drawWallFace w wall | isRHS sightFrom x y || _wlIsSeeThrough wall = blank - | otherwise = setDepth (-0.1) . polygon $ points + | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points where (x:y:_) = _wlLine wall points = extendConeToScreenEdge w sightFrom (x,y) @@ -322,75 +203,12 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] + wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x)) . 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) $ @@ -425,11 +243,6 @@ drawFFShadow w ff , 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 - wallsPointsAndCols :: World -> [((Point2,Point2),Point4)] wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where linePairs (x:y:_) = (x,y) diff --git a/src/Dodge/Rendering/HUD.hs b/src/Dodge/Rendering/HUD.hs index 889a271fa..328f7c872 100644 --- a/src/Dodge/Rendering/HUD.hs +++ b/src/Dodge/Rendering/HUD.hs @@ -9,6 +9,30 @@ import Picture import Geometry import Data.Maybe +import qualified Data.IntMap as IM + +import Control.Lens + + +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) + +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 closeObjectTexts :: World -> Picture closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w) @@ -59,3 +83,27 @@ closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _cl ,(sc p' , col) ,(sc p , col) ] + +dShadCol :: Color -> Picture -> Picture +dShadCol c p = pictures $ + [ color black $ uncurry translate (1.2,-1.2) p + , color c p + ] + +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 + +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 + diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 44b637987..0d056fef0 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -48,23 +48,25 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol ) :: IO (GLmatrix GLfloat) createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat + ticksAfterLighting <- SDL.ticks + renderBackground pdata rot zoom trans wins renderWalls pdata wallPointsCol pmat + setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat depthFunc $= Just Lequal renderFoldable pdata $ picToLTree (Just 0) pic - -- reset blend so that light map doesn't apply blendFunc $= (SrcAlpha,OneMinusSrcAlpha) renderFoldable pdata $ picToLTree (Just 1) pic -- set drawing for on top - blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) +-- blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) renderFoldable pdata $ picToLTree (Just 2) pic @@ -83,6 +85,26 @@ renderWalls pdata wps pmat = do $= pmat drawShader (_wallFaceShader pdata) n +setWallDepth :: RenderData -> [(Point2,Point2)] -> (Float,Float) -> GLmatrix GLfloat -> IO Word32 +setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do + startTicks <- SDL.ticks + colorMask $= (Color4 Disabled Disabled Disabled Disabled) + nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints + bindShaderBuffers [_wallShadowShader pdata] [nWalls] + + currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) + uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) + $= Vector2 viewFromx viewFromy + uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1) + $= pmat + uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2) + $= (0 :: Float) +-- cullFace $= Just Front + drawShader (_wallShadowShader pdata) nWalls + colorMask $= (Color4 Enabled Enabled Enabled Enabled) + endTicks <- SDL.ticks + return $ endTicks - startTicks + createLightMap :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> [(Point2,Point2)] -> [Point4] -> (Float,Float) -> GLmatrix GLfloat -> IO () @@ -116,7 +138,6 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints cullFace $= Just Back drawShader (_wallShadowShader pdata) nWalls - depthMask $= Disabled blendFunc $= (Zero, OneMinusSrcAlpha) -- blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha)) @@ -163,11 +184,6 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints cullFace $= Nothing stencilTest $= Disabled - startWallTicks <- SDL.ticks - wallPokeEnd <- SDL.ticks - ticksS <- SDL.ticks - ticksAfterL <- SDL.ticks - blend $= Disabled -- blendFunc $= (Zero,One)