Improve window drawing

shader/wall/blank.geom

@@ -20,8 +20,8 @@ void main()
   vec4 a1 = theMat * p1;
   vec4 a2 = theMat * p2;
 //  if (0 > isLHS (a1.xy - a2.xy, a1.xy - "viewFromPoint")) {
-    vec4 p3 = vec4 (p1.xy,100,1);
-    vec4 p4 = vec4 (p2.xy,100,1);
+    vec4 p3 = vec4 (p1.xy,5000,1); //note the random z value, used for GL_DEPTH_CLAMP
+    vec4 p4 = vec4 (p2.xy,5000,1);
     vec4 a3 = theMat * p3;
     vec4 a4 = theMat * p4;
     gPos = p1;gl_Position = a1; EmitVertex();

src/Dodge/Material/Damage.hs

@@ -24,6 +24,7 @@ damMatSideEffect dm = \case
     Flesh -> damageFlesh dm
     Dirt -> damageDirt dm
     --    Glass -> damageGlass dm
+    Crystal -> \ecw -> set _1 0 . defDamageMaterial dm ecw
     _ -> defDamageMaterial dm
 
 defDamageMaterial :: Damage -> ECW -> World -> (Int,World)

src/Dodge/Projectile/Update.hs

@@ -2,6 +2,7 @@
 --{-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.Projectile.Update (updateProjectile) where
 
+import Dodge.WorldEvent.Cloud
 import Control.Monad
 import Data.List (delete)
 import Data.Maybe
@@ -126,8 +127,8 @@ tryThrust pj = fromMaybe id $ do
     return $ doThrust pj x . pjRemoteSetDirection y pj
 
 doThrust :: Projectile -> Maybe RocketSmoke -> World -> World
---doThrust pj smoke w =
-doThrust pj _ w =
+doThrust pj smoke w =
+--doThrust pj _ w =
     w
         & randGen .~ g
         & cWorld . lWorld . projectiles . ix i . pjVel . _xy %~ (\v -> accel + frict *^ v)
@@ -137,15 +138,15 @@ doThrust pj _ w =
             (vel + rotateV (pi + sparkD) accel `v2z` 0)
             3
             10
---        & makeCloudAt
---            RocketSmoke
---            lifetime
---            (sp + r1 + 30 *^ signorm (sp - ep))
+        & makeCloudAt
+            RocketSmoke
+            lifetime
+            (sp + r1 + 30 *^ signorm (sp - ep))
   where
---    lifetime = fst . randomR lt $ _randGen w
---    lt
---        | smoke == Just ReducedRocketSmoke = (50, 200)
---        | otherwise = (300, 500)
+    lifetime = fst . randomR lt $ _randGen w
+    lt
+        | smoke == Just ReducedRocketSmoke = (50, 200)
+        | otherwise = (300, 500)
     accel = rotateV (pj ^. pjDir) (V2 3 0)
     i = _pjID pj
     sp = pj ^. pjPos
@@ -153,7 +154,7 @@ doThrust pj _ w =
     ep = sp + vel
     (frict, g) = randomR (0.6, 0.9) $ _randGen w
     (sparkD, _) = randomR (-0.2, 0.2) $ _randGen w
---    r1 = addZ 0 $ randInCirc 10 & evalState $ _randGen w
+    r1 = addZ 0 $ randInCirc 10 & evalState $ _randGen w
 
 doBarrelSpin :: Int -> Float -> Projectile -> World -> World
 doBarrelSpin cid i pj w =

src/Dodge/Render.hs

@@ -307,7 +307,12 @@ doDrawing' win pdata u = do
         (fromIntegral nCloudIs)
         GL_UNSIGNED_SHORT
         nullPtr
+    glEnable GL_CULL_FACE
+    glEnable GL_DEPTH_CLAMP
+    glCullFace GL_BACK
     drawShader (_windowShader pdata) nWins
+    glDisable GL_DEPTH_CLAMP
+    glDisable GL_CULL_FACE
     when (_graphics_cloud_shadows cfig) $ do
         ----render transparency depths
         glDepthMask GL_TRUE
@@ -340,7 +345,7 @@ doDrawing' win pdata u = do
             (fromIntegral nCloudIs)
             GL_UNSIGNED_SHORT
             nullPtr
-        drawShader (_windowShader pdata) nWins
+--        drawShader (_windowShader pdata) nWins
         glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboPos . _1 . unFBO)
         withArray [0, 0, 0, 0] $ \ptr ->
             glClearNamedFramebufferfv

src/Dodge/Room/Tutorial.hs

@@ -48,7 +48,7 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
-        , tToBTree "cor" . return . cleatOnward <$> southPillarsRoom 300 300 100
+        , return . tToBTree "asdf" . return . cleatOnward $ airlockCrystal
 --        , tToBTree "x" . return . cleatOnward <$> airlockSimple
 --        , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
         , return $ tToBTree "cor" $ return $ cleatOnward corridor
@@ -65,7 +65,6 @@ tutAnoTree = do
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , tToBTree "asdf" . return . cleatOnward <$> airlockZ
-        --, return . tToBTree "asdf" . return . cleatOnward $ airlockCrystal
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
         , tToBTree "t" . return . cleatOnward <$> slowDoorRoom

src/Dodge/Update/Camera.hs

@@ -24,6 +24,7 @@ import Dodge.Zoning.Wall
 import Geometry
 import LensHelp
 import SDL (MouseButton (..))
+import qualified SDL as SDL
 
 {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
 update where your avatar's view is from.  -}
@@ -63,10 +64,12 @@ translateFloatingCamera theinput cam = fromMaybe cam $ do
 translateFloatingCameraKeys :: Input -> Camera -> Camera
 translateFloatingCameraKeys theinput cam =
     cam
-        & camCenter -~ thetran
-        & camViewFrom -~ thetran
+        & camCenter -~ x
+        & camViewFrom -~ y
   where
-    thetran = rotateV (cam ^. camRot) $ negate 10 *.* wasdDir theinput
+    x = rotateV (cam ^. camRot) $ negate 10 *.* wasdDir theinput
+    y | SDL.ScancodeLShift `M.member` (theinput ^. pressedKeys) = 0
+        | otherwise = x
 
 zoomFloatingCamera :: Input -> Camera -> Camera
 zoomFloatingCamera theinput

src/Dodge/Update/WallDamage.hs

@@ -3,6 +3,7 @@ module Dodge.Update.WallDamage (updateWallDamages, updateEdgesWall) where
 import Control.Lens
 import Data.Foldable
 import Data.Maybe
+import Data.Monoid
 import qualified Data.Set as S
 import Dodge.Data.World
 import Dodge.Wall.Damage
@@ -23,9 +24,16 @@ updateWallDamages w =
 
 updateEdgesWall :: S.Set Int2 -> World -> World
 updateEdgesWall is w =
-    updateEdgesWall'
-        (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is)
-        w
+    hack $
+        updateEdgesWall'
+            (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is)
+            w
+  where
+    hack w'
+        | null is = w'
+        | otherwise =
+            (foldMap Sum $ w' ^.. cWorld . incGraph . each . each . seObstacles . to length)
+                `seq` w'
 
 updateEdgesWall' :: S.Set (Int, Int) -> World -> World
 updateEdgesWall' = flip $ foldl' updateEdgeWallObs

src/Dodge/WorldBool.hs

@@ -13,7 +13,6 @@ doWdBl wb w = case wb of
     WdTrig i -> fromMaybe False $ w ^? cWorld . lWorld . triggers . ix i
     WdBlDoorMoving i -> fromMaybe False $ do
         dr <- w ^? cWorld . lWorld . doors . ix i
-        --return (DoorHalfway == _drStatus dr)
         return (0 /= _drLerp dr && 1 /= _drLerp dr)
     WdBlCrFilterNearPoint r p t -> any (crNearPoint r p) (IM.filter (doCrBl t) (w ^. cWorld . lWorld . creatures))
     WdBlBtOn btid -> w ^?! cWorld . lWorld . buttons . ix btid . btEvent . btOn -- unsafe

src/Dodge/WorldEvent/Explosion.hs

@@ -11,7 +11,7 @@ module Dodge.WorldEvent.Explosion (
 import Control.Monad
 import Data.List
 import Dodge.Data.World
---import Dodge.EnergyBall
+import Dodge.EnergyBall
 import Dodge.SoundLogic
 import Dodge.WorldEvent.Shockwave
 import Dodge.WorldEvent.SpawnParticle
@@ -20,7 +20,7 @@ import LensHelp
 import Picture
 import RandomHelp
 import Linear.V3
---import Linear.Metric
+import Linear.Metric
 
 makePoisonExplosionAt ::
     -- | Position
@@ -71,25 +71,25 @@ makeFlameExplosionAt p w =
 -- particle passes through for the first frame of its existence
 
 makeExplosionAt :: Point3 -> Point3 -> World -> World
---makeExplosionAt p vel w =
-makeExplosionAt p _ w =
+makeExplosionAt p vel w =
+--makeExplosionAt p _ w =
     w
         & soundStart (Explosion (w ^. cWorld . lWorld . lClock)) (p ^. _xy) bangS Nothing
---        & addFlames
+        & addFlames
         & cWorld . lWorld . worldEvents 
             .:~ MakeTempLight (LSParam p 150 (V3 1 0.5 0)) 20
---        & makeShockwaveAt [] p 50 50 1 white
-        & makeShockwaveAt [] p 50 5000 1 white
+        & makeShockwaveAt [] p 50 100 1 white
+--        & makeShockwaveAt [] p 50 5000 1 white
   where
---    fVs = fmap (`v2z` 0) $ replicateM 100 (randInCirc 1) & evalState $ _randGen w
---    fPs' = fmap (`v2z` 0) $ replicateM 100 (randInCirc 5) & evalState $ _randGen w
---    fdamps = replicateM 100 (state $ randomR (0,1)) & evalState $ _randGen w
---    inversePushOut v = (15 - norm v) * 0.01 *.*.* v
---    fVs' = zipWith (+.+.+) fVs $ map inversePushOut fPs'
---    sizes = randomRs (2, 9) $ _randGen w
---    times = randomRs (15, 20) $ _randGen w
---    mF q v damp size time = makeFlamelet 
---        --(q - (2*v + 2* vel)) (v + damp *.*.* vel) size time
---        (q - (2*v )) (v + damp *.*.* vel) size time
---    newFs = zipWith4 (mF p) (zipWith (+) fPs' (fmap (3 *.*.*) fVs')) fdamps sizes times
---    addFlames w' = foldl' (flip ($)) w' newFs
+    fVs = fmap (`v2z` 0) $ replicateM 100 (randInCirc 1) & evalState $ _randGen w
+    fPs' = fmap (`v2z` 0) $ replicateM 100 (randInCirc 5) & evalState $ _randGen w
+    fdamps = replicateM 100 (state $ randomR (0,1)) & evalState $ _randGen w
+    inversePushOut v = (15 - norm v) * 0.01 *.*.* v
+    fVs' = zipWith (+.+.+) fVs $ map inversePushOut fPs'
+    sizes = randomRs (2, 9) $ _randGen w
+    times = randomRs (15, 20) $ _randGen w
+    mF q v damp size time = makeFlamelet 
+        --(q - (2*v + 2* vel)) (v + damp *.*.* vel) size time
+        (q - (2*v )) (v + damp *.*.* vel) size time
+    newFs = zipWith4 (mF p) (zipWith (+) fPs' (fmap (3 *.*.*) fVs')) fdamps sizes times
+    addFlames w' = foldl' (flip ($)) w' newFs