Set windows to blend, fix depth of walls again

2021-03-22 02:31:58 +01:00
parent 5c23e0a348
commit 7aacaccc8c
3 changed files with 87 additions and 210 deletions
@@ -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)
@@ -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
+
@@ -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)