diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 59d352584..a645e4c88 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -32,6 +32,7 @@ lev1 = do ( [return $ return $ Right deadEndRoom ] + ++[roomMiniIntro] ++ [longRoom >>= randomiseLinks] ++ [return $ connectRoom corridor ,return $ connectRoom door] diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs index 48c18095f..f5f27757d 100644 --- a/src/Dodge/LevelGen/AutoDoor.hs +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -28,13 +28,6 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr]) xs (lDoorClosed ++ rDoorClosed) (map shiftL lDoorClosed ++ map shiftR rDoorClosed) - -- [ [plld,pld] - -- , [pld,plu] - -- , [plu,pllu] - -- , [prru,pru] - -- , [pru,prd] - -- , [prd,prrd] - -- ] where lDoorClosed = [ [pld,hwd] , [hwd,hwu] , [hwu,plu] @@ -45,7 +38,6 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr]) ] norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl)) hw = 0.5 *.* (pl +.+ pr) - --parallel = 15 *.* normalizeV (pl -.- pr) parallel = 0.5 *.* (pl -.- pr) plu = pl +.+ norm pld = pl -.- norm @@ -56,14 +48,10 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr]) shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel) shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel) - pllu = plu +.+ parallel - plld = pld +.+ parallel - prru = pru -.- parallel - prrd = prd -.- parallel addSound (x:xs) = f x : xs f wl = over doorMech g wl - g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 - $ dm w + g dm w | dist wp pld > 1 && dist wp hwd > 1 + = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w | otherwise = dm w where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1 diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index f8b83eed2..f8e2f8f22 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -66,12 +66,12 @@ worldPictures w , ptPicts , ptPicts' , afterPtPicts' --- , wlPicts' , wlPicts , smokeShadows , ppLabels , btLabels , testPic w + , wallsToSetDepth ] where decPicts = IM.elems $ _decorations w @@ -84,7 +84,7 @@ worldPictures 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) + wallsToSetDepth = map (drawWallFace w) (wallShadowsToDraw w) itFloorPicts = map drawItem (IM.elems (_floorItems w)) yourPos = _crPos $ you w yourRot = _crDir $ you w @@ -271,9 +271,9 @@ outsideScreenPolygon w = [tr,tl,bl,br] x = halfWidth w + halfHeight w wallShadowsToDraw :: World -> [Wall] -wallShadowsToDraw w = --IM.elems $ _walls w - filter isVisible $ IM.elems -- $ _walls w - $ wallsNearZones (zoneOfSight w) w +wallShadowsToDraw w = filter isVisible + . 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 @@ -299,21 +299,12 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 drawWallFace :: World -> Wall -> Picture drawWallFace w wall - | isRHS sightFrom x y = blank - | otherwise = colorAndLayer $ polygon $ points + | isRHS sightFrom x y || _wlIsSeeThrough wall = blank + | otherwise = setLayer 3 . setDepth 1 . 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: @@ -445,7 +436,8 @@ wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ walls f wl = (linePairs $ _wlLine wl, _wlColor wl) wallsWindows :: World -> [((Point2,Point2),Point4)] -wallsWindows w = map f . filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w +wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) . + filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where linePairs (x:y:_) = (x,y) f wl = (linePairs $ _wlLine wl, _wlColor wl) @@ -455,12 +447,6 @@ wallsForShadows w = map (linePairs . _wlLine) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w where linePairs (x:y:_) = (x,y) -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) diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index b09bccf54..5f61c9937 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -31,16 +31,6 @@ import qualified Data.IntMap.Strict as IM import qualified SDL as SDL -setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO () -setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do - setShaderUniforms rot zoom (tranx,trany) (winx,winy) - ( (extractProgAndUnis $ _lightSourceShader pdata) - : (extractProgAndUnis $ _wallShadowShader pdata) - : (extractProgAndUnis $ _wallLightShader pdata) - : (extractProgAndUnis $ _backgroundShader pdata) - : (map extractProgAndUnis $ _listShaders pdata) - ) - renderPicture' :: RenderData -> Float -> Float -> Point2 -> Point2 -> [((Point2,Point2),Point4)] -> [((Point2,Point2),Point4)] -> [Point4] -> (Float,Float) -> Picture -> IO (Word32,Word32) @@ -61,13 +51,21 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol ticksAfterLighting <- SDL.ticks renderBackground pdata rot zoom trans wins + renderWalls pdata wallPointsCol pmat + + renderWalls pdata windowPoints pmat + +-- hack: the walls are drawn with a continuous depth from 0 to -1 +-- the following call is aimed at setting the depth buffer over all the walls to +-- at most -0.9 + colorMask $= (Color4 Disabled Disabled Disabled Disabled) + renderFoldable pdata $ picToLTree (Just 3) pic + colorMask $= (Color4 Enabled Enabled Enabled Enabled) + depthFunc $= Just Lequal renderFoldable pdata $ picToLTree (Just 0) pic - renderWalls pdata wallPointsCol pmat - - renderWalls pdata windowPoints pmat -- reset blend so that light map doesn't apply blendFunc $= (SrcAlpha,OneMinusSrcAlpha) @@ -209,25 +207,15 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do textureBinding Texture2D $= (fmap _textureObject $ _shaderTexture $ _backgroundShader pdata) drawArrays Points (fromIntegral 0) (fromIntegral 1) -renderPicture :: RenderData -> Picture -> IO () -renderPicture pdata pic = do - - depthFunc $= Just Lequal - --- draw layer 0 - ticks2 <- renderFoldable pdata $ picToLTree (Just 0) pic - --((picToAlt 0 pic) :: [RenderType]) --- reset blend so that light map doesn't apply - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - ticks3 <- renderFoldable pdata $ picToLTree (Just 1) pic --- set drawing for on top - aticks <- SDL.ticks - blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) - ticks4 <- renderFoldable pdata $ picToLTree (Just 2) pic - bticks <- SDL.ticks - - resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata) - +setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO () +setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do + setShaderUniforms rot zoom (tranx,trany) (winx,winy) + ( (extractProgAndUnis $ _lightSourceShader pdata) + : (extractProgAndUnis $ _wallShadowShader pdata) + : (extractProgAndUnis $ _wallLightShader pdata) + : (extractProgAndUnis $ _backgroundShader pdata) + : (map extractProgAndUnis $ _listShaders pdata) + ) renderFoldable :: Foldable f => RenderData -> f RenderType -> IO Word32 renderFoldable pdata tree = do @@ -247,7 +235,6 @@ renderFoldable pdata tree = do pokeEndTicks <- SDL.ticks return $ pokeEndTicks - pokeStartTicks - ------------------------------end renderFoldable @@ -269,34 +256,3 @@ pokeFourOff ptr n (x,y,z,w) = do pokeElemOff ptr (4*n+1) y pokeElemOff ptr (4*n+2) z pokeElemOff ptr (4*n+3) w - -mkShadFromWall :: (Point2,Point2,Point2,Point2) -> Point4 -> [(Point3,Point4)] -{-# INLINE mkShadFromWall #-} -mkShadFromWall (wla,wlb,_,_) (x,y,r,_) - = makeHexahedron $ prismQuad (f wla - ,f wlb - ,f $ wla +.+ r *.* normalizeV (wla -.- ls) - ,f $ wlb +.+ r *.* normalizeV (wlb -.- ls) - ) - where f (x,y) = (x,y,0) - ls = (x,y) - -prismQuad :: (Point3,Point3,Point3,Point3) -> - (Point3,Point3,Point3,Point3 - ,Point3,Point3,Point3,Point3) -{-# INLINE prismQuad #-} -prismQuad (a,b,c,d) = (a,b,c,d,f a,f b,f d,f c) - where f (x,y,z) = (x,y,z-0.5) - --- note this doubles the first and last points, assumes these points will be --- input as part of a triangle strip -makeHexahedron :: (Point3,Point3,Point3,Point3 - ,Point3,Point3,Point3,Point3) -> [(Point3,Point4)] -{-# INLINE makeHexahedron #-} -makeHexahedron (a1,a2,a3,a4,a5,a6,a7,a8) - = [cr a4 ,cr a4 ,cr a3 ,cr a7 ,cr a8 - ,cr a5 ,cr a3 ,cb a1 ,cb a4 ,cr a2 ,cr a7 ,cr a6 ,cr a5 ,cr a2 ,cr a1 ,cr a1 ] - where col = (1,0,1,0.1) - cr a = (a,(1,0,0,0.1)) - cg a = (a,(0,1,0,0.1)) - cb a = (a,(0,0,1,0.1))