From a2183151be0580b751182d9bb3191ca8f54af885 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sat, 20 Mar 2021 12:28:19 +0100
Subject: [PATCH 01/17] Lower walls and performance improvement for shadows

---
 shader/wallShadow.geom | 24 ++++++++++++++----------
 src/Dodge/Rendering.hs |  4 ++--
 src/Picture/Render.hs  |  6 +++---
 3 files changed, 19 insertions(+), 15 deletions(-)

diff --git a/shader/wallShadow.geom b/shader/wallShadow.geom
index 99a7fa666..98efbb3aa 100644
--- a/shader/wallShadow.geom
+++ b/shader/wallShadow.geom
@@ -6,29 +6,28 @@ uniform vec2 lightPos;
 uniform mat4 perpMat;
 uniform mat4 worldMat;
 
-vec2 lightPosa = lightPos;
+vec2 lightPosa = ( perpMat * vec4(lightPos,0,1) ).xy;
 
 vec4 shift (vec4 p)
-{ return vec4 (p.xy + (200 * (p.xy-lightPosa)), 0 , 1);
+{ return vec4 (p.xy + (200 * (p.xy-lightPos)), 0 , 1);
 }
 float isLHS (vec2 startV, vec2 testV)
 {
     return sign( -startV.x * testV.y + startV.y * testV.x);
 }
-// construct a box with opening on bottom face
-
+// construct a box with openings on bottom face and face away from wall
 void main()
 {
 vec4 p1 = vec4 (gl_in[0].gl_Position.xy,0,1);
 vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1);
-if (isLHS (p1.xy - lightPosa, p2.xy - lightPosa) < 0)
+if (isLHS (p1.xy - lightPos, p2.xy - lightPos) < 0)
 {
-vec4 p3 = vec4 (p1.xy,-0.5,1);
-vec4 p4 = vec4 (p2.xy,-0.5,1);
+vec4 p3 = vec4 (p1.xy,-0.2,1);
+vec4 p4 = vec4 (p2.xy,-0.2,1);
 vec4 p5 = shift(p1);
 vec4 p6 = shift(p2);
-vec4 p7 = vec4 (p6.xy,-0.5,1);
-vec4 p8 = vec4 (p5.xy,-0.5,1);
+vec4 p7 = vec4 (p6.xy,-0.2,1);
+vec4 p8 = vec4 (p5.xy,-0.2,1);
 
 vec4 a1 = perpMat * p1;
 vec4 a2 = perpMat * p2;
@@ -39,6 +38,11 @@ vec4 a6 = perpMat * p6;
 vec4 a7 = perpMat * p7;
 vec4 a8 = perpMat * p8;
 
+//  gl_Position = a1; EmitVertex();
+//  gl_Position = a5; EmitVertex();
+//  gl_Position = a2; EmitVertex();
+//  gl_Position = a6; EmitVertex();
+
   gl_Position = a4; EmitVertex();
   gl_Position = a3; EmitVertex();
   gl_Position = a7; EmitVertex();
@@ -50,7 +54,7 @@ vec4 a8 = perpMat * p8;
   gl_Position = a2; EmitVertex();
   gl_Position = a7; EmitVertex();
   gl_Position = a6; EmitVertex();
-//  gl_Position = a5; EmitVertex();
+
   EndPrimitive();
 } else {}
 }
diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index 6e2669140..7f9b4c689 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -122,8 +122,8 @@ worldPictures w
                 where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
 
 testPic :: World -> [Picture]
-testPic w = --[blank]
-     [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ]
+testPic w = [blank]
+    -- [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ]
     -- $ uncurry translate (mouseWorldPos w) 
 
 
diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs
index fe0c51b8d..157b2e7a4 100644
--- a/src/Picture/Render.hs
+++ b/src/Picture/Render.hs
@@ -68,9 +68,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
 
     currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
     uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
-            $= Vector2 viewFromx viewFromy  -- hopefully this draws as if from the center
-                                     -- it does, but this is not correct when
-                                     -- the camera center is not the player position
+            $= Vector2 viewFromx viewFromy  
     pmat <- (newMatrix RowMajor 
                 $ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
             ) :: IO (GLmatrix GLfloat)
@@ -85,6 +83,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     stencilTest $= Enabled
     forM_ lightPoints $ \(x,y,r,lum) -> do
 --        depthFunc $= Just Less
+        colorMask $= (Color4 Disabled Disabled Disabled Disabled)
         clear [StencilBuffer]
         cullFace $= Just Back
 --        stencilOp $= (OpKeep,OpKeep,OpReplace)
@@ -103,6 +102,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
 
         cullFace $= Nothing
         
+        colorMask $= (Color4 Enabled Enabled Enabled Enabled)
         let lightPtr = (\(_,ptr,_) -> ptr) $ head 
                             $ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
             (x',y') = zTran $ rotateV (0 - rot) $ (x,y) -.- (tranx,trany)

From 0b1f7f50c3bdccd7dae526afe522a529168c9917 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sat, 20 Mar 2021 13:28:39 +0100
Subject: [PATCH 02/17] Black out high walls

---
 shader/lightmapCircle.geom | 8 ++++----
 shader/wallShadow.geom     | 1 +
 src/Picture/Preload.hs     | 2 +-
 src/Picture/Render.hs      | 3 +++
 4 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/shader/lightmapCircle.geom b/shader/lightmapCircle.geom
index a68259370..a32186b49 100644
--- a/shader/lightmapCircle.geom
+++ b/shader/lightmapCircle.geom
@@ -16,13 +16,13 @@ void main()
 
   cenPosT = vec2 ( (cenPos.x + 1) * 0.5 * winSize.x , (cenPos.y + 1) * 0.5 * winSize.y);
 
-  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.9 , 1);
+  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.2 , 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.9 , 1);
+  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.2 , 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.9 , 1);
+  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.2 , 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.9 , 1);
+  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.2 , 1);
   EmitVertex();
 
   EndPrimitive();
diff --git a/shader/wallShadow.geom b/shader/wallShadow.geom
index 98efbb3aa..b98b9b652 100644
--- a/shader/wallShadow.geom
+++ b/shader/wallShadow.geom
@@ -5,6 +5,7 @@ layout (triangle_strip, max_vertices = 11) out;
 uniform vec2 lightPos;
 uniform mat4 perpMat;
 uniform mat4 worldMat;
+uniform float facesToDraw;
 
 vec2 lightPosa = ( perpMat * vec4(lightPos,0,1) ).xy;
 
diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs
index b520ddbd8..bb529bc65 100644
--- a/src/Picture/Preload.hs
+++ b/src/Picture/Preload.hs
@@ -46,7 +46,7 @@ preloadRender = do
                                 "data/texture/smudgedDirt.png"
 
     wsShad <- makeShaderCustomUnis "wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
-                ["lightPos","perpMat"]
+                ["lightPos","perpMat","facesToDraw"]
 
     wlLightShad <- makeShaderCustomUnis "wallLight" [vert,frag] [(0,3)] TriangleStrip pokeLightWallStrat
                     ["lightPosRadLum"]
diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs
index 157b2e7a4..940655306 100644
--- a/src/Picture/Render.hs
+++ b/src/Picture/Render.hs
@@ -74,7 +74,10 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
             ) :: IO (GLmatrix GLfloat)
     uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1)
             $= pmat
+    uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2)
+            $= (0 :: Float)
     cullFace $= Just Back
+    cullFace $= Nothing
     drawShader (_wallShadowShader pdata) nWalls
 
     depthMask $= Disabled

From 19fc1f246860ad8d47c2b5d08cb11cca0c6c9590 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sat, 20 Mar 2021 14:08:59 +0100
Subject: [PATCH 03/17] Implement automatic reload

---
 src/Dodge/AIs.hs            | 18 +-----------------
 src/Dodge/CreatureAction.hs |  8 +++++++-
 2 files changed, 8 insertions(+), 18 deletions(-)

diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs
index 68e5712a3..23d7ec50b 100644
--- a/src/Dodge/AIs.hs
+++ b/src/Dodge/AIs.hs
@@ -39,22 +39,6 @@ import Foreign.ForeignPtr
 import Control.Concurrent
 ---}
 
---killCr :: World -> (World -> World) -> Creature -> ((World -> World,StdGen), Maybe Creature)
---killCr w f cr = ((g . f, _randGen w),Nothing)
---    where crBeforeDeath = colCrWall w $ cr
---          addCorpse = insertNewKey $ uncurry translate (_crPos crBeforeDeath) 
---                                   $ rotate (radToDeg (_crDir cr))
---                                   (_crCorpse cr)
---          maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w)
---          insertIt = case maybeIt of 
---                        Just it -> createItemAt (offset +.+ _crPos crBeforeDeath) 
---                                                (FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0})
---                        Nothing -> id
---          offset = _crRad cr *.* unitVectorAtAngle rot
---          (rot,_) = randomR (-pi,pi) $ _randGen w
---          g  = stopSoundFrom (CrWeaponSound (_crID cr)) . over decorations addCorpse . insertIt
-
-
 factionIs :: Faction -> Creature -> Bool
 factionIs f c = (_faction $ _crState $ c) == f
 
@@ -1888,7 +1872,7 @@ spCrRadFac = 8^2
 
 yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
 yourControl w (f,g) cr = ( (mouseActionsWorld (_mouseButtons w) . f, g)
-                         , Just $ mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
+                         , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
                          )
     where strafeSpeed = 3 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
           speed = 3 * equipFactor
diff --git a/src/Dodge/CreatureAction.hs b/src/Dodge/CreatureAction.hs
index b468dba15..333ee0243 100644
--- a/src/Dodge/CreatureAction.hs
+++ b/src/Dodge/CreatureAction.hs
@@ -207,7 +207,13 @@ reloadWeapon cid w =
                                             $ set ( itRef . wpReloadState) rT w
         _                          -> Nothing
 
-
+crAutoReload :: Creature -> Creature
+crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
+        Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
+                     & crInv . ix (_crInvSel cr) . wpLoadedAmmo  %~ (`fromMaybe` maxA)
+        _      -> cr
+    where reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
+          maxA    = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
 
 createItemAt :: Point2 -> FloorItem -> World -> World
 createItemAt p it w = over floorItems (IM.insert i (set flItPos p 

From 4365185f9f727778e4c7e32132dc6e185767fd53 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sat, 20 Mar 2021 18:51:03 +0100
Subject: [PATCH 04/17] Decrease muzzle flare light time

---
 src/Dodge/Data.hs                    |  2 +-
 src/Dodge/Item/Weapon.hs             | 44 ++++++++++++++++------------
 src/Dodge/Item/Weapon/TriggerType.hs |  6 ++--
 src/Geometry.hs                      |  6 +++-
 src/Loop.hs                          |  1 -
 5 files changed, 34 insertions(+), 25 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 3ff6532ae..d503bb621 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -573,9 +573,9 @@ data Wall
         , _blHP :: Int
         , _wlIsSeeThrough :: Bool
         , _blVisible :: Bool
-        , _blShadows :: [Int]
         , _blDegrades :: [Int]
         , _wlCastShadow :: Bool
+        , _blShadows :: [Int]
         }
     | MultiBlock
         { _wlLine :: [Point2]
diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs
index 4e3f5d4cc..f7039b9f6 100644
--- a/src/Dodge/Item/Weapon.hs
+++ b/src/Dodge/Item/Weapon.hs
@@ -62,6 +62,7 @@ pistol = Weapon
     , _wpFireState = 0
     , _wpFire = shootWithSound 0 
                 . withRandomDir 0.1
+                . withMuzFlare
                 . withVelWthHiteff (30,0) 2 
                 $ threeEff' bulHitCr' bulHitWall' bulHitFF'
     , _wpSpread = 0.02
@@ -124,17 +125,19 @@ autoGun = defaultGun
     , _itInvDisplay = displayAutoGun
     }
 autoFireMode = shootWithSound (fromIntegral autoGunSound) 
-                   $ withRecoil 40
-                   $ torqueBefore 0.05
-                   $ withRandomDir (autogunSpread/2)
-                   $ withVelWthHiteff (50,0) 3 
-                          $ threeEff' bulHitCr' bulHitWall' bulHitFF'
+                   . withRecoil 40
+                   . torqueBefore 0.05
+                   . withRandomDir (autogunSpread/2)
+                   . withMuzFlare
+                   . withVelWthHiteff (50,0) 3 
+                   $ threeEff' bulHitCr' bulHitWall' bulHitFF'
 singleFireMode = shootWithSound (fromIntegral autoGunSound) 
-                   $ withRecoil 40
-                   $ torqueAfter 0.03
-                   $ withRandomDir (autogunSpread/2)
-                   $ withVelWthHiteff (50,0) 3 
-                          $ threeEff' bulHitCr' bulHitWall' bulHitFF'
+                   . withRecoil 40
+                   . torqueAfter 0.03
+                   . withRandomDir (autogunSpread/2)
+                   . withMuzFlare
+                   . withVelWthHiteff (50,0) 3 
+                   $ threeEff' bulHitCr' bulHitWall' bulHitFF'
 
 incMode :: Int -> World -> World
 incMode _ w 
@@ -422,9 +425,10 @@ hvAutoGun = defaultAutoGun
     , _itEquipPict = drawWeapon $ color orange $ polygon $ rectNESW 5 5 (-5) (-5)
     }
         where mkHvBul = withSound (fromIntegral longGunSound)
-                            $ withThinSmoke
-                            $ withVelWthHiteff (80,0) 6 
-                                    $ threeEff' 
+                            . withThinSmoke
+                            . withMuzFlare
+                            . withVelWthHiteff (80,0) 6 
+                            $ threeEff' 
                                         hvBulHitCr' hvBulHitWall' bulHitFF'
                             
 ltAutoGun = defaultAutoGun 
@@ -436,7 +440,8 @@ ltAutoGun = defaultAutoGun
     , _wpReloadState = 0
     , _wpFireRate = 4
     , _wpFireState = 0
-    , _wpFire = shootWithSound 0 . withRandomDir 0.3 $ withVelWthHiteff (30,0) 2 bulletEffect'
+    , _wpFire = shootWithSound 0 . withRandomDir 0.3 
+                         . withMuzFlare $ withVelWthHiteff (30,0) 2 bulletEffect'
     , _wpSpread = 0.5
     , _wpRange = 20
     , _itFloorPict = onLayer FlItLayer $ color green $ pictures [polygon $ rectNSWE 4 (-4) (-4) 0
@@ -463,6 +468,7 @@ miniGun = defaultAutoGun
     , _wpFire = withWarmUp 50 . torqueBefore 0.03 . withSidePush 50 . withRecoil 15
                         . withRandomDir 0.1
                         . withRandomOffset 9
+                        . withMuzFlare
                         $ withVelWthHiteff (30,0) 2 bulletEffect'
     , _wpSpread = autogunSpread
     , _wpRange = 20
@@ -555,11 +561,11 @@ longGun = defaultGun
     , _wpFireRate = 100
     , _wpFireState = 0
     , _wpFire = shootWithSound (fromIntegral longGunSound)
-                $ withThickSmoke
-                $ torqueAfter 0.05
-                $ withVelWthHiteff (60,0) 6 
-                                    $ threeEff'
-                                        hvBulHitCr' hvBulHitWall' bulHitFF'
+                . withThickSmoke
+                . torqueAfter 0.05
+                . withMuzFlare
+                . withVelWthHiteff (60,0) 6 
+                $ threeEff' hvBulHitCr' hvBulHitWall' bulHitFF'
 
     , _wpSpread = 0.0
     , _wpRange = 200
diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs
index 48814cb52..97d3c7ae1 100644
--- a/src/Dodge/Item/Weapon/TriggerType.hs
+++ b/src/Dodge/Item/Weapon/TriggerType.hs
@@ -94,7 +94,7 @@ shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> am
           reloadCondition = _wpLoadedAmmo item == 0
 
 withMuzFlare :: (Int -> World -> World) -> Int -> World -> World
-withMuzFlare f cid w = over tempLightSources (tLightAt 4 pos :)
+withMuzFlare f cid w = over tempLightSources (tLightAt 3 pos :)
                       . lowLightAt pos2 $ f cid w
     where cr = _creatures w IM.! cid
           dir = _crDir cr
@@ -112,8 +112,8 @@ withRandomDir acc f cid w = over (creatures . ix cid . crDir) (\d -> d - a)
 withVelWthHiteff :: Point2 -> Float -> HitEffect' -> Int -> World -> World
 withVelWthHiteff vel width hiteff cid w 
     = over particles' ((:) newbul)
-        . over tempLightSources ((:) (tLightAt 4 pos))
-        . lowLightAt pos2
+--        . over tempLightSources ((:) (tLightAt 4 pos))
+--        . lowLightAt pos2
         $ set randGen g
         w
     where cr = _creatures w IM.! cid
diff --git a/src/Geometry.hs b/src/Geometry.hs
index 67f13627f..e2e2d40af 100644
--- a/src/Geometry.hs
+++ b/src/Geometry.hs
@@ -36,6 +36,7 @@ closestPointOnLineParam a b p
 rectNESW :: Float -> Float -> Float -> Float -> [Point2]
 rectNESW a b c d = [(b,a),(b,c),(d,c),(d,a)
                    ]
+rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
 rectNSEW n s e w = rectNESW n e s w
 
 rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
@@ -89,6 +90,7 @@ safeNormalizeV p = normalizeV p
 -- this has been called somewhere with l1 == l2
 isLHS :: Point2 -> Point2 -> Point2 -> Bool
 {-# INLINE isLHS #-}
+isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool
 isLHS' l1 l2 p | l1 == l2  = False
               | otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0
 
@@ -138,6 +140,7 @@ circOnLine p1 p2 c rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
           isJustTrue (Just True) = True
           isJustTrue _           = False
 
+difference :: (Ord a, Num a) => a -> a -> a
 difference x y | x > y = x - y
                | otherwise = y - x
 
@@ -145,6 +148,7 @@ reflectIn :: Point2 -> Point2 -> Point2
 reflectIn line vec = let angle = 2 * angleBetween line vec
                      in  rotateV angle vec
 
+angleBetween :: Point2 -> Point2 -> Float
 angleBetween v1 v2 = argV v1 - argV v2
 
 doublePair :: (a,a) -> [(a,a)]
@@ -195,7 +199,7 @@ ssaTri :: Float -> Float -> Float -> Float
 ssaTri ab bc a 
     | sin a == 0 = 0
     | bc == 0    = ab
-    | otherwise = let c = asin ( (ab * (sin a))/bc)
+    | otherwise = let c = asin ( (ab * sin a)/bc)
                       b = pi - (a + c)
                   in  sin b * bc / sin a
 
diff --git a/src/Loop.hs b/src/Loop.hs
index 752e173af..ce1d724a9 100644
--- a/src/Loop.hs
+++ b/src/Loop.hs
@@ -10,7 +10,6 @@ import qualified Graphics.Rendering.OpenGL as GL
 import Control.Monad
 import System.Mem
 import Foreign.C
-import Geometry
 
 import Preload
 

From a8aa19bb188062243c32ee1d5df727105ed59554 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sat, 20 Mar 2021 20:39:55 +0100
Subject: [PATCH 05/17] Refactor floor lighting shader with distance field

---
 shader/lightmapCircle.frag |  9 +++++----
 shader/lightmapCircle.geom | 11 ++++++++---
 2 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/shader/lightmapCircle.frag b/shader/lightmapCircle.frag
index c29090cf5..7a6466b7e 100644
--- a/shader/lightmapCircle.frag
+++ b/shader/lightmapCircle.frag
@@ -1,12 +1,13 @@
 #version 430 core
 in vec2 cenPosT;
-in vec2 gParams;
+in float lum;
+
+in vec2 dField;
+
 out vec4 fColor;
 
 void main()
 {
-  vec2 pos = gl_FragCoord.xy;
-  float dist = min(1 , 2*distance(pos,cenPosT) / (gParams.x));
-  float c = gParams.y * pow(1-dist,2);
+  float c = pow (1 - min(1, dot(dField,dField)) , 2) * lum ;
   fColor = vec4(c,c,c,c);
 }
diff --git a/shader/lightmapCircle.geom b/shader/lightmapCircle.geom
index a32186b49..a8790706a 100644
--- a/shader/lightmapCircle.geom
+++ b/shader/lightmapCircle.geom
@@ -2,26 +2,31 @@
 layout (points) in;
 layout (triangle_strip, max_vertices = 4) out;
 in vec2 vParams [];
-out vec2 gParams;
+out float lum;
 out vec2 cenPosT;
+out vec2 dField;
 
 uniform vec2 winSize;
 uniform float zoom;
 
 void main()
 {
+  lum = vParams[0].y;
   vec3 cenPos = gl_in[0].gl_Position.xyz;
-  gParams = vec2( vParams[0].x * zoom * 2, vParams[0].y);
-  float gRad = gParams.x;
+  float gRad = vParams[0].x * zoom * 2;
 
   cenPosT = vec2 ( (cenPos.x + 1) * 0.5 * winSize.x , (cenPos.y + 1) * 0.5 * winSize.y);
 
+  dField = vec2 ( 1, 1);
   gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.2 , 1);
   EmitVertex();
+  dField = vec2 (-1, 1);
   gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.2 , 1);
   EmitVertex();
+  dField = vec2 ( 1,-1);
   gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.2 , 1);
   EmitVertex();
+  dField = vec2 (-1,-1);
   gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.2 , 1);
   EmitVertex();
 

From e7b4e54f9a9f999507a03496d2ff27ae04cea86e Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 11:11:44 +0100
Subject: [PATCH 06/17] Add lighting on walls, imperfect

---
 shader/lightmapCircle.geom |  8 ++--
 shader/lightmapWall.frag   | 13 ++++++
 shader/lightmapWall.geom   | 86 ++++++++++++++++++++++++++++++++++++++
 shader/lightmapWall.vert   |  7 ++++
 shader/wallShadow.geom     |  8 ++--
 src/Dodge/Rendering.hs     | 12 +-----
 src/Picture/Preload.hs     |  7 ++--
 src/Picture/Render.hs      | 67 +++++++++--------------------
 8 files changed, 140 insertions(+), 68 deletions(-)
 create mode 100644 shader/lightmapWall.frag
 create mode 100644 shader/lightmapWall.geom
 create mode 100644 shader/lightmapWall.vert

diff --git a/shader/lightmapCircle.geom b/shader/lightmapCircle.geom
index a8790706a..f1f3d2615 100644
--- a/shader/lightmapCircle.geom
+++ b/shader/lightmapCircle.geom
@@ -18,16 +18,16 @@ void main()
   cenPosT = vec2 ( (cenPos.x + 1) * 0.5 * winSize.x , (cenPos.y + 1) * 0.5 * winSize.y);
 
   dField = vec2 ( 1, 1);
-  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.2 , 1);
+  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
   EmitVertex();
   dField = vec2 (-1, 1);
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.2 , 1);
+  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
   EmitVertex();
   dField = vec2 ( 1,-1);
-  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.2 , 1);
+  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
   EmitVertex();
   dField = vec2 (-1,-1);
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.2 , 1);
+  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
   EmitVertex();
 
   EndPrimitive();
diff --git a/shader/lightmapWall.frag b/shader/lightmapWall.frag
new file mode 100644
index 000000000..935723836
--- /dev/null
+++ b/shader/lightmapWall.frag
@@ -0,0 +1,13 @@
+#version 430 core
+in vec2 cenPosT;
+in float lum;
+
+in vec3 dField;
+
+out vec4 fColor;
+
+void main()
+{
+  float c = pow (1 - min(1, dot(dField,dField)) , 2) * lum ;
+  fColor = vec4(c,c,c,c);
+}
diff --git a/shader/lightmapWall.geom b/shader/lightmapWall.geom
new file mode 100644
index 000000000..07e5a31a0
--- /dev/null
+++ b/shader/lightmapWall.geom
@@ -0,0 +1,86 @@
+#version 430 core
+layout (points) in;
+layout (triangle_strip, max_vertices = 4) out;
+
+out vec3 dField;
+out float lum;
+
+uniform vec2 lightPos;
+uniform mat4 perpMat;
+uniform vec2 radLum;
+
+float isLHS (vec2 startV, vec2 testV)
+{
+    return sign( -startV.x * testV.y + startV.y * testV.x);
+}
+vec4 shiftUp (vec4 v)
+{ return vec4 (v.xy , v.z-0.1 , v.w) ; }
+
+void main()
+{
+vec4 p1 = vec4 (gl_in[0].gl_Position.xy,0,1);
+vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1);
+if (isLHS (p1.xy - lightPos, p2.xy - lightPos) < 0)
+{
+    lum = radLum.y;
+    float rad = radLum.x;
+
+    vec4 p3 = vec4 (p1.xy,-0.2,1);
+    vec4 p4 = vec4 (p2.xy,-0.2,1);
+
+    vec2 d1 = p1.xy - lightPos;
+    vec2 d2 = p2.xy - lightPos;
+    
+    vec4 a1 = shiftUp( perpMat * p1 );
+    vec4 a2 = shiftUp( perpMat * p2 );
+    vec4 a3 = shiftUp( perpMat * p3 );
+    vec4 a4 = shiftUp( perpMat * p4 );
+    
+    dField = vec3( d1.x/rad, d1.y/rad, 0);
+    gl_Position = a1; 
+    EmitVertex();
+    dField = vec3( d1.x/rad, d1.y/rad, 1);
+    gl_Position = a3; 
+    EmitVertex();
+    dField = vec3( d2.x/rad, d2.y/rad, 0);
+    gl_Position = a2; 
+    EmitVertex();
+    dField = vec3( d2.x/rad, d2.y/rad, 1);
+    gl_Position = a4; 
+    EmitVertex();
+    
+    EndPrimitive();
+} else {}
+}
+
+//  //  void main()
+//  //  {
+//  //    vec4 frontL4 = worldMat * vec4(gl_in[0].gl_Position.xy, 0 ,1);
+//  //    vec4 frontR4 = worldMat * vec4(gl_in[0].gl_Position.zw, 0 ,1);
+//  //    vec2 frontL = frontL4.xy;
+//  //    vec2 frontR = frontR4.xy;
+//  //  
+//  //      emitLine (frontR);
+//  //      emitLine (frontL);
+//  //    EndPrimitive();
+//  //  }
+//  gl_Position = perspective * worldMat * p4; EmitVertex();
+//  gl_Position = perspective * worldMat * p3; EmitVertex();
+//  gl_Position = perspective * worldMat * p7; EmitVertex();
+//  gl_Position = perspective * worldMat * p8; EmitVertex();
+//  gl_Position = perspective * worldMat * p5; EmitVertex();
+//  gl_Position = perspective * worldMat * p3; EmitVertex();
+//  gl_Position = perspective * worldMat * p1; EmitVertex();
+//  gl_Position = perspective * worldMat * p4; EmitVertex();
+//  gl_Position = perspective * worldMat * p2; EmitVertex();
+//  gl_Position = perspective * worldMat * p7; EmitVertex();
+//  gl_Position = perspective * worldMat * p6; EmitVertex();
+//  gl_Position = perspective * worldMat * p5; EmitVertex();
+//void emitLine (vec2 pa)
+//{
+//    gl_Position = vec4 (pa, 0, 1);
+//    EmitVertex();
+//    gl_Position = shift (vec4 (pa,0,1)); //vec4 (pa + (200 * (pa - lightPosa)), 0 , 1);
+//    EmitVertex();
+//}
+
diff --git a/shader/lightmapWall.vert b/shader/lightmapWall.vert
new file mode 100644
index 000000000..15bfe7fc0
--- /dev/null
+++ b/shader/lightmapWall.vert
@@ -0,0 +1,7 @@
+#version 430 core
+layout (location = 0) in vec4 poss;
+
+void main()
+{
+  gl_Position = poss;
+}
diff --git a/shader/wallShadow.geom b/shader/wallShadow.geom
index b98b9b652..a029e1180 100644
--- a/shader/wallShadow.geom
+++ b/shader/wallShadow.geom
@@ -23,12 +23,12 @@ vec4 p1 = vec4 (gl_in[0].gl_Position.xy,0,1);
 vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1);
 if (isLHS (p1.xy - lightPos, p2.xy - lightPos) < 0)
 {
-vec4 p3 = vec4 (p1.xy,-0.2,1);
-vec4 p4 = vec4 (p2.xy,-0.2,1);
+vec4 p3 = vec4 (p1.xy,-0.5,1);
+vec4 p4 = vec4 (p2.xy,-0.5,1);
 vec4 p5 = shift(p1);
 vec4 p6 = shift(p2);
-vec4 p7 = vec4 (p6.xy,-0.2,1);
-vec4 p8 = vec4 (p5.xy,-0.2,1);
+vec4 p7 = vec4 (p6.xy,-0.5,1);
+vec4 p8 = vec4 (p5.xy,-0.5,1);
 
 vec4 a1 = perpMat * p1;
 vec4 a2 = perpMat * p2;
diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index 7f9b4c689..e06603b3c 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -505,13 +505,5 @@ wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
 
 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 = _lsPos 
-          sstls = _tlsPos 
---          ssls = ss . _lsPos 
---          sstls = ss . _tlsPos 
-          zoom = _cameraZoom w
+    where getLS ls  = ( fst $ _lsPos ls, snd $ _lsPos ls,  _lsRad ls , _lsIntensity ls)
+          getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos ls, _tlsRad ls, _tlsIntensity ls)
diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs
index bb529bc65..3d066fbc9 100644
--- a/src/Picture/Preload.hs
+++ b/src/Picture/Preload.hs
@@ -23,7 +23,7 @@ import qualified Control.Foldl as F
 data RenderData = RenderData
     { _lightSourceShader :: FullShader (Float,Float,Float,Float)
     , _wallShadowShader  :: FullShader (Point2,Point2)
-    , _wallLightShader  :: FullShader (Point3)
+    , _wallLightShader   :: FullShader (Point2,Point2)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
     , _wallShader :: FullShader (Point3,Point4)
@@ -48,8 +48,9 @@ preloadRender = do
     wsShad <- makeShaderCustomUnis "wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
                 ["lightPos","perpMat","facesToDraw"]
 
-    wlLightShad <- makeShaderCustomUnis "wallLight" [vert,frag] [(0,3)] TriangleStrip pokeLightWallStrat
-                    ["lightPosRadLum"]
+    wlLightShad 
+         <- makeShaderCustomUnis "lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+                    ["lightPos","perpMat","radLum"]
 
     wlShad <- makeShader "wall" [vert,frag] [(0,3),(1,4)] TriangleStrip pokeWlStrat
 
diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs
index 940655306..3892713af 100644
--- a/src/Picture/Render.hs
+++ b/src/Picture/Render.hs
@@ -61,7 +61,18 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     clearDepth $= 1
     clear [ColorBuffer,DepthBuffer]
 
-    nWalls <- F.foldM (pokeShader (_wallShadowShader pdata)) wallPoints
+-- calculate perspective matrix
+    pmat <- (newMatrix RowMajor 
+                $ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
+            ) :: IO (GLmatrix GLfloat)
+
+    nWallLights <- F.foldM (pokeShader $ _wallLightShader pdata) wallPoints
+    bindShaderBuffers [_wallLightShader pdata] [nWallLights]
+    currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
+    uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1)
+            $= pmat
+
+    nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
     bindShaderBuffers [_wallShadowShader pdata] [nWalls]
 
     let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy)
@@ -69,9 +80,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
     uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
             $= Vector2 viewFromx viewFromy  
-    pmat <- (newMatrix RowMajor 
-                $ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
-            ) :: IO (GLmatrix GLfloat)
     uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1)
             $= pmat
     uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2)
@@ -80,6 +88,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     cullFace $= Nothing
     drawShader (_wallShadowShader pdata) nWalls
 
+
     depthMask $= Disabled
     blendFunc $= (Zero, OneMinusSrcAlpha)
 --    blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
@@ -114,14 +123,14 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
         bindShaderBuffers [_lightSourceShader pdata] [1]
         stencilFunc $= (Equal, 0, 255)
         drawShader (_lightSourceShader pdata) 1
-        
---        currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
---        uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
---            $= Vector4 x y r lum
---        cullFace $= Just Front
---        depthFunc $= Just Lequal
---        drawShader (_wallLightShader pdata) nLightWalls
 
+        currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
+        uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
+                $= Vector2 x y  
+        uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 2)
+                $= Vector2 r lum
+        drawShader (_wallLightShader pdata) nWallLights
+        
     depthMask $= Enabled
     cullFace $= Nothing
     stencilTest $= Disabled
@@ -176,42 +185,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
     bticks <- SDL.ticks
 
--- render walls
---    depthFunc $= Nothing
---    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
---    -- poke data
---    cullFace $= Just Back
---    let lights = map (\(x,y,r,g) -> ((x,y),(r,g,0,0))) lightPoints
---        wallPairs = map (\(a,b,_,_) -> [(a,(1,1,1,1)),(b,(1,1,1,1))]) wallPoints
---        f (x,y) = [(x,y,0),(x,y,0),(x,y,-1)]
---        g (x,y) = [(x,y,0),(x,y,-1),(x,y,-1)]
---        wp = concatMap (\(a,b,_,_) -> f a ++ g b) wallPoints
---        h p = (p,(1,0,0,1))
---        wp2 = ((200,200),(-200,200),(0,0),(0,0))
---        wp3 = ((-200,200),(-200,-200),(0,0),(0,0))
---    i <- F.foldM (pokeShader (_wallShader pdata)) $ concat $ mkShadFromWall <$> [wp2,wp3] <*> [(300,50,200,0)]
---
---    -- bind buffers
---    bindShaderBuffers [_wallShader pdata] [i]
---
---    -- draw call
---    drawShaders [_wallShader pdata] [i]
---    depthFunc $= Just Lequal
-
-------    blendFunc $= (One,Zero)
-------    let f (x,y) = (x,y,0)
-------        h (x,y) = (x,y,-1)
-------        g (a,b) = [f a,f a,h a,f b,h b,h b]
-------        wp = concatMap g [((200,200),(-200,200))]
-------    nLightWalls <- F.foldM (pokeShader (_wallLightShader pdata)) wp
-------    bindShaderBuffers [_wallLightShader pdata] [nLightWalls]
-------    currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
-------    uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
-------        $= Vector4 (0::Float) 0 200 0.5
-------    cullFace $= Just Front
-------    depthFunc $= Just Lequal
-------    drawShader (_wallLightShader pdata) nLightWalls
-
     resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
 
     endWallTicks <- SDL.ticks

From a8ebf2f7f19fa82b07e059703fc5d45e1a5923d1 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 12:27:57 +0100
Subject: [PATCH 07/17] Draw floor of windows

---
 shader/lightmapWall.geom | 12 ++++++------
 src/Dodge/Floor.hs       |  2 +-
 src/Dodge/Rendering.hs   |  4 +++-
 3 files changed, 10 insertions(+), 8 deletions(-)

diff --git a/shader/lightmapWall.geom b/shader/lightmapWall.geom
index 07e5a31a0..ca1cf858a 100644
--- a/shader/lightmapWall.geom
+++ b/shader/lightmapWall.geom
@@ -13,8 +13,8 @@ float isLHS (vec2 startV, vec2 testV)
 {
     return sign( -startV.x * testV.y + startV.y * testV.x);
 }
-vec4 shiftUp (vec4 v)
-{ return vec4 (v.xy , v.z-0.1 , v.w) ; }
+vec4 shiftCloser (vec4 v)
+{ return vec4 (v.xy , v.z-0.0001 , v.w) ; }
 
 void main()
 {
@@ -31,10 +31,10 @@ if (isLHS (p1.xy - lightPos, p2.xy - lightPos) < 0)
     vec2 d1 = p1.xy - lightPos;
     vec2 d2 = p2.xy - lightPos;
     
-    vec4 a1 = shiftUp( perpMat * p1 );
-    vec4 a2 = shiftUp( perpMat * p2 );
-    vec4 a3 = shiftUp( perpMat * p3 );
-    vec4 a4 = shiftUp( perpMat * p4 );
+    vec4 a1 = shiftCloser( perpMat * p1 );
+    vec4 a2 = shiftCloser( perpMat * p2 );
+    vec4 a3 = shiftCloser( perpMat * p3 );
+    vec4 a4 = shiftCloser( perpMat * p4 );
     
     dField = vec3( d1.x/rad, d1.y/rad, 0);
     gl_Position = a1; 
diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs
index eac928237..977c2be27 100644
--- a/src/Dodge/Floor.hs
+++ b/src/Dodge/Floor.hs
@@ -32,7 +32,7 @@ lev1 = do
             (
             [return $ return $ Right deadEndRoom
             ]
-            ++ [slowDoorRoom]
+            ++ [roomMiniIntro]
             ++ [return $ connectRoom corridor
                ,return $ connectRoom door]
             ++ firstWeapon
diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index e06603b3c..47a3be055 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -70,6 +70,7 @@ worldPictures w
                         , ptPicts'
                         , afterPtPicts'
                         , wlPicts'
+                        , wlPicts
 --                        , wallShadows
                         , smokeShadows
 --                        , itLabels
@@ -337,7 +338,8 @@ drawWall' w wall
         f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
         f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
         points = orderPolygon (borderps ++ ps)
-        --points = orderPolygon (borderps ++ p's)
+        wallBase | _wlIsSeeThrough wall = polygon $ _wlLine wall
+                 | otherwise = blank
 
 drawWallShadow :: World -> Wall -> Drawing
 drawWallShadow w wall

From cf5a8b3e1b969c54406d9fb84b874aef1811b9c5 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 12:50:27 +0100
Subject: [PATCH 08/17] Reorganise shaders

---
 shader/{ => Old}/wall.frag                |  0
 shader/{ => Old}/wall.geom                |  0
 shader/{ => Old}/wall.vert                |  0
 shader/{ => Old}/wallLight.frag           |  0
 shader/{ => Old}/wallLight.geom           |  0
 shader/{ => Old}/wallLight.vert           |  0
 shader/{ => lighting}/lightmapCircle.frag |  0
 shader/{ => lighting}/lightmapCircle.geom |  0
 shader/{ => lighting}/lightmapCircle.vert |  0
 shader/{ => lighting}/lightmapWall.frag   |  0
 shader/{ => lighting}/lightmapWall.geom   |  0
 shader/{ => lighting}/lightmapWall.vert   |  0
 shader/{ => lighting}/wallShadow.frag     |  0
 shader/{ => lighting}/wallShadow.geom     |  0
 shader/{ => lighting}/wallShadow.vert     |  0
 shader/{ => twoD}/arc.frag                |  0
 shader/{ => twoD}/arc.geom                |  0
 shader/{ => twoD}/arc.vert                |  0
 shader/{ => twoD}/basic.frag              |  0
 shader/{ => twoD}/basic.vert              |  0
 shader/{ => twoD}/bezierQuad.frag         |  0
 shader/{ => twoD}/bezierQuad.geom         |  0
 shader/{ => twoD}/bezierQuad.vert         |  0
 shader/{ => twoD}/character.frag          |  0
 shader/{ => twoD}/character.geom          |  0
 shader/{ => twoD}/character.vert          |  0
 shader/{ => twoD}/ellipse.frag            |  0
 shader/{ => twoD}/ellipse.geom            |  0
 shader/{ => twoD}/ellipse.vert            |  0
 src/Dodge/Rendering.hs                    | 52 +++++------------------
 src/Picture/Preload.hs                    | 29 ++++++-------
 src/Picture/Render.hs                     |  1 -
 32 files changed, 22 insertions(+), 60 deletions(-)
 rename shader/{ => Old}/wall.frag (100%)
 rename shader/{ => Old}/wall.geom (100%)
 rename shader/{ => Old}/wall.vert (100%)
 rename shader/{ => Old}/wallLight.frag (100%)
 rename shader/{ => Old}/wallLight.geom (100%)
 rename shader/{ => Old}/wallLight.vert (100%)
 rename shader/{ => lighting}/lightmapCircle.frag (100%)
 rename shader/{ => lighting}/lightmapCircle.geom (100%)
 rename shader/{ => lighting}/lightmapCircle.vert (100%)
 rename shader/{ => lighting}/lightmapWall.frag (100%)
 rename shader/{ => lighting}/lightmapWall.geom (100%)
 rename shader/{ => lighting}/lightmapWall.vert (100%)
 rename shader/{ => lighting}/wallShadow.frag (100%)
 rename shader/{ => lighting}/wallShadow.geom (100%)
 rename shader/{ => lighting}/wallShadow.vert (100%)
 rename shader/{ => twoD}/arc.frag (100%)
 rename shader/{ => twoD}/arc.geom (100%)
 rename shader/{ => twoD}/arc.vert (100%)
 rename shader/{ => twoD}/basic.frag (100%)
 rename shader/{ => twoD}/basic.vert (100%)
 rename shader/{ => twoD}/bezierQuad.frag (100%)
 rename shader/{ => twoD}/bezierQuad.geom (100%)
 rename shader/{ => twoD}/bezierQuad.vert (100%)
 rename shader/{ => twoD}/character.frag (100%)
 rename shader/{ => twoD}/character.geom (100%)
 rename shader/{ => twoD}/character.vert (100%)
 rename shader/{ => twoD}/ellipse.frag (100%)
 rename shader/{ => twoD}/ellipse.geom (100%)
 rename shader/{ => twoD}/ellipse.vert (100%)

diff --git a/shader/wall.frag b/shader/Old/wall.frag
similarity index 100%
rename from shader/wall.frag
rename to shader/Old/wall.frag
diff --git a/shader/wall.geom b/shader/Old/wall.geom
similarity index 100%
rename from shader/wall.geom
rename to shader/Old/wall.geom
diff --git a/shader/wall.vert b/shader/Old/wall.vert
similarity index 100%
rename from shader/wall.vert
rename to shader/Old/wall.vert
diff --git a/shader/wallLight.frag b/shader/Old/wallLight.frag
similarity index 100%
rename from shader/wallLight.frag
rename to shader/Old/wallLight.frag
diff --git a/shader/wallLight.geom b/shader/Old/wallLight.geom
similarity index 100%
rename from shader/wallLight.geom
rename to shader/Old/wallLight.geom
diff --git a/shader/wallLight.vert b/shader/Old/wallLight.vert
similarity index 100%
rename from shader/wallLight.vert
rename to shader/Old/wallLight.vert
diff --git a/shader/lightmapCircle.frag b/shader/lighting/lightmapCircle.frag
similarity index 100%
rename from shader/lightmapCircle.frag
rename to shader/lighting/lightmapCircle.frag
diff --git a/shader/lightmapCircle.geom b/shader/lighting/lightmapCircle.geom
similarity index 100%
rename from shader/lightmapCircle.geom
rename to shader/lighting/lightmapCircle.geom
diff --git a/shader/lightmapCircle.vert b/shader/lighting/lightmapCircle.vert
similarity index 100%
rename from shader/lightmapCircle.vert
rename to shader/lighting/lightmapCircle.vert
diff --git a/shader/lightmapWall.frag b/shader/lighting/lightmapWall.frag
similarity index 100%
rename from shader/lightmapWall.frag
rename to shader/lighting/lightmapWall.frag
diff --git a/shader/lightmapWall.geom b/shader/lighting/lightmapWall.geom
similarity index 100%
rename from shader/lightmapWall.geom
rename to shader/lighting/lightmapWall.geom
diff --git a/shader/lightmapWall.vert b/shader/lighting/lightmapWall.vert
similarity index 100%
rename from shader/lightmapWall.vert
rename to shader/lighting/lightmapWall.vert
diff --git a/shader/wallShadow.frag b/shader/lighting/wallShadow.frag
similarity index 100%
rename from shader/wallShadow.frag
rename to shader/lighting/wallShadow.frag
diff --git a/shader/wallShadow.geom b/shader/lighting/wallShadow.geom
similarity index 100%
rename from shader/wallShadow.geom
rename to shader/lighting/wallShadow.geom
diff --git a/shader/wallShadow.vert b/shader/lighting/wallShadow.vert
similarity index 100%
rename from shader/wallShadow.vert
rename to shader/lighting/wallShadow.vert
diff --git a/shader/arc.frag b/shader/twoD/arc.frag
similarity index 100%
rename from shader/arc.frag
rename to shader/twoD/arc.frag
diff --git a/shader/arc.geom b/shader/twoD/arc.geom
similarity index 100%
rename from shader/arc.geom
rename to shader/twoD/arc.geom
diff --git a/shader/arc.vert b/shader/twoD/arc.vert
similarity index 100%
rename from shader/arc.vert
rename to shader/twoD/arc.vert
diff --git a/shader/basic.frag b/shader/twoD/basic.frag
similarity index 100%
rename from shader/basic.frag
rename to shader/twoD/basic.frag
diff --git a/shader/basic.vert b/shader/twoD/basic.vert
similarity index 100%
rename from shader/basic.vert
rename to shader/twoD/basic.vert
diff --git a/shader/bezierQuad.frag b/shader/twoD/bezierQuad.frag
similarity index 100%
rename from shader/bezierQuad.frag
rename to shader/twoD/bezierQuad.frag
diff --git a/shader/bezierQuad.geom b/shader/twoD/bezierQuad.geom
similarity index 100%
rename from shader/bezierQuad.geom
rename to shader/twoD/bezierQuad.geom
diff --git a/shader/bezierQuad.vert b/shader/twoD/bezierQuad.vert
similarity index 100%
rename from shader/bezierQuad.vert
rename to shader/twoD/bezierQuad.vert
diff --git a/shader/character.frag b/shader/twoD/character.frag
similarity index 100%
rename from shader/character.frag
rename to shader/twoD/character.frag
diff --git a/shader/character.geom b/shader/twoD/character.geom
similarity index 100%
rename from shader/character.geom
rename to shader/twoD/character.geom
diff --git a/shader/character.vert b/shader/twoD/character.vert
similarity index 100%
rename from shader/character.vert
rename to shader/twoD/character.vert
diff --git a/shader/ellipse.frag b/shader/twoD/ellipse.frag
similarity index 100%
rename from shader/ellipse.frag
rename to shader/twoD/ellipse.frag
diff --git a/shader/ellipse.geom b/shader/twoD/ellipse.geom
similarity index 100%
rename from shader/ellipse.geom
rename to shader/twoD/ellipse.geom
diff --git a/shader/ellipse.vert b/shader/twoD/ellipse.vert
similarity index 100%
rename from shader/ellipse.vert
rename to shader/twoD/ellipse.vert
diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index 47a3be055..ad0963400 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -71,9 +71,7 @@ worldPictures w
                         , afterPtPicts'
                         , wlPicts'
                         , wlPicts
---                        , wallShadows
                         , smokeShadows
---                        , itLabels
                         , ppLabels
                         , btLabels
                         , testPic w
@@ -87,11 +85,10 @@ worldPictures 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)
-          wlPicts'      = map (drawWall' w) (wallsToDraw w)
-          itFloorPicts  = map (drawItem) (IM.elems (_floorItems w))
+          wlPicts       = map drawWallFloor (wallFloorsToDraw w)
+          wlPicts'      = map (drawWall w) (wallShadowsToDraw w)
+          itFloorPicts  = map drawItem (IM.elems (_floorItems w))
           yourPos = _crPos $ you w
           yourRot = _crDir $ you w
           yourRad = _crRad $ you w
@@ -199,8 +196,8 @@ mapWall wl =
           (x:y:_) = _wlLine wl
           c = _wlColor wl
 
-wallsToDraw :: World -> [Wall]
-wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
+wallFloorsToDraw :: World -> [Wall]
+wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
     where onScreen wall = lineOnScreen w (_wlLine wall)
           isVisible wl | wl ^? blVisible == Just False = False
                        | otherwise = onScreen wl
@@ -245,11 +242,10 @@ drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps,
         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}) 
+drawWallFloor :: Wall -> Drawing
+drawWallFloor (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
+drawWallFloor wl = case _wlDraw wl of
         Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
         Just d -> d wl
     where 
@@ -261,7 +257,6 @@ drawWall wl = case _wlDraw wl of
         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"
@@ -312,8 +307,8 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
     where sp = screenPolygon w
           sps = zip sp (tail sp ++ [head sp])
 
-drawWall' :: World -> Wall -> Drawing
-drawWall' w wall
+drawWall :: World -> Wall -> Drawing
+drawWall w wall
     | isRHS sightFrom x y = blank
     | otherwise = colorAndLayer $ polygon $ points
     where 
@@ -341,33 +336,6 @@ drawWall' w wall
         wallBase | _wlIsSeeThrough wall = polygon $ _wlLine wall
                  | otherwise = blank
 
-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']
diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs
index 3d066fbc9..d57b62b32 100644
--- a/src/Picture/Preload.hs
+++ b/src/Picture/Preload.hs
@@ -26,7 +26,7 @@ data RenderData = RenderData
     , _wallLightShader   :: FullShader (Point2,Point2)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
-    , _wallShader :: FullShader (Point3,Point4)
+--    , _wallShader :: FullShader (Point3,Point4)
     , _listShaders :: [FullShader RenderType]
     , _dummyVBO :: BufferObject
     , _dummyPtr :: Ptr Float
@@ -39,32 +39,31 @@ makeLenses ''RenderData
 preloadRender :: IO RenderData
 preloadRender = do
 -- compile shader programs
-    lsShad <- makeShader "lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
+    lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
 --    fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
 
     bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
                                 "data/texture/smudgedDirt.png"
 
-    wsShad <- makeShaderCustomUnis "wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+    wsShad <- makeShaderCustomUnis "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
                 ["lightPos","perpMat","facesToDraw"]
 
     wlLightShad 
-         <- makeShaderCustomUnis "lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+         <- makeShaderCustomUnis "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
                     ["lightPos","perpMat","radLum"]
 
-    wlShad <- makeShader "wall" [vert,frag] [(0,3),(1,4)] TriangleStrip pokeWlStrat
+--    wlShad <- makeShader "wall" [vert,frag] [(0,3),(1,4)] TriangleStrip pokeWlStrat
 
-    bslist <- makeShader "basic"   [vert,frag]      [(0,3),(1,4)]       Triangles pokeTriStrat
-    lslist <- makeShader "basic"   [vert,frag]      [(0,3),(1,4)]       Lines     pokeLineStrat
-    aslist <- makeShader "arc"     [vert,geom,frag] [(0,3),(1,4),(2,4)] Points    pokeArcStrat
-    eslist <- makeShader "ellipse" [vert,geom,frag] [(0,3),(1,4)]       Triangles pokeEllStrat
-    cslist <- makeTextureShader "character" [vert,geom,frag] 
+    bslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Triangles pokeTriStrat
+    lslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Lines     pokeLineStrat
+    aslist <- makeShader "twoD/arc"     [vert,geom,frag] [(0,3),(1,4),(2,4)] Points    pokeArcStrat
+    eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [(0,3),(1,4)]       Triangles pokeEllStrat
+    bezierQuadShader <- makeShader 
+                      "twoD/bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)]    TriangleStrip pokeBezQStrat
+    cslist <- makeTextureShader "twoD/character" [vert,geom,frag] 
                                 [(0,3),(1,4),(2,3)] Points pokeCharStrat
                                 "data/texture/charMap.png"
 
-    bezierQuadShader
-           <- makeShader "bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)]    TriangleStrip pokeBezQStrat
-
     fsShad <- makeShader "fullscreen" [vert,frag] [(0,2),(1,2)] TriangleStrip 
                                 (const [[[-1, 1],[0,1]]
                                        ,[[ 1, 1],[1,1]]
@@ -97,7 +96,6 @@ preloadRender = do
         , _lightSourceShader = lsShad
         , _wallShadowShader  = wsShad
         , _wallLightShader   = wlLightShad
-        , _wallShader        = wlShad
         , _backgroundShader  = bgShad
         , _fullscreenShader  = fsShad
         , _spareFBO = fbo
@@ -150,9 +148,6 @@ pokeTriStrat :: RenderType -> [[[Float]]]
 pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
 pokeTriStrat _ = []
 
-pokeWlStrat :: (Point3,Point4) -> [[[Float]]]
-pokeWlStrat ((x,y,z),(r,g,b,a)) = [[[x,y,z],[r,g,b,a]]]
-
 pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> flat3 (flat3 a, flat4 b, flat3 c)) vs
 pokeCharStrat _ = []
 
diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs
index 3892713af..106b19b9c 100644
--- a/src/Picture/Render.hs
+++ b/src/Picture/Render.hs
@@ -48,7 +48,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
         ( (extractProgAndUnis $ _lightSourceShader pdata) 
         : (extractProgAndUnis $ _wallShadowShader pdata) 
         : (extractProgAndUnis $ _wallLightShader pdata) 
-        : (extractProgAndUnis $ _wallShader pdata) 
         : (extractProgAndUnis $ _backgroundShader pdata) 
         : (map extractProgAndUnis $ _listShaders pdata)
         )

From 4dc1f8e6bf42f8cb83da1e2fb77e4e77152679f3 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 12:54:55 +0100
Subject: [PATCH 09/17] Remove dummy vbo

---
 src/Picture/Preload.hs | 32 ++++++++------------------------
 1 file changed, 8 insertions(+), 24 deletions(-)

diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs
index d57b62b32..f0c539087 100644
--- a/src/Picture/Preload.hs
+++ b/src/Picture/Preload.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
---{-# LANGUAGE Strict #-}
 module Picture.Preload
     ( RenderData (..)
     , preloadRender
@@ -26,10 +25,7 @@ data RenderData = RenderData
     , _wallLightShader   :: FullShader (Point2,Point2)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
---    , _wallShader :: FullShader (Point3,Point4)
     , _listShaders :: [FullShader RenderType]
-    , _dummyVBO :: BufferObject
-    , _dummyPtr :: Ptr Float
     , _spareFBO :: FramebufferObject
     , _fboTexture :: TextureObject
     }
@@ -39,21 +35,16 @@ makeLenses ''RenderData
 preloadRender :: IO RenderData
 preloadRender = do
 -- compile shader programs
-    lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
---    fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
-
-    bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
-                                "data/texture/smudgedDirt.png"
-
+-- lighting shaders
+    lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points 
+                    (return . return . flat4)
     wsShad <- makeShaderCustomUnis "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
                 ["lightPos","perpMat","facesToDraw"]
-
     wlLightShad 
          <- makeShaderCustomUnis "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
                     ["lightPos","perpMat","radLum"]
 
---    wlShad <- makeShader "wall" [vert,frag] [(0,3),(1,4)] TriangleStrip pokeWlStrat
-
+-- 2D draw shaders
     bslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Triangles pokeTriStrat
     lslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Lines     pokeLineStrat
     aslist <- makeShader "twoD/arc"     [vert,geom,frag] [(0,3),(1,4),(2,4)] Points    pokeArcStrat
@@ -64,6 +55,7 @@ preloadRender = do
                                 [(0,3),(1,4),(2,3)] Points pokeCharStrat
                                 "data/texture/charMap.png"
 
+-- fullscreen shader
     fsShad <- makeShader "fullscreen" [vert,frag] [(0,2),(1,2)] TriangleStrip 
                                 (const [[[-1, 1],[0,1]]
                                        ,[[ 1, 1],[1,1]]
@@ -72,15 +64,10 @@ preloadRender = do
                                        ]
                                  )
     n <- F.foldM (pokeShader fsShad) [()]
-    putStrLn $ show n
-
---the following vbo is set up to contain one fixed vertex
-    dummyvbo <- genObjectName
-    dummyptr <- mallocArray numDrawableElements
-    pokeArray dummyptr [0..2000]
-    bindBuffer ArrayBuffer $= Just dummyvbo
-    bufferData ArrayBuffer $= (fromIntegral floatSize, dummyptr, StaticDraw)
 
+-- background shader
+    bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
+                                "data/texture/smudgedDirt.png"
 -- input a list of (attribute location, attrib length) pairs
 -- these will have buffers and pointers created
     backgroundvao <- setupVAO [(0,4),(1,2)]
@@ -91,8 +78,6 @@ preloadRender = do
     
     return $ RenderData
         { _listShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
-        , _dummyVBO = dummyvbo
-        , _dummyPtr = dummyptr
         , _lightSourceShader = lsShad
         , _wallShadowShader  = wsShad
         , _wallLightShader   = wlLightShad
@@ -134,7 +119,6 @@ cleanUpRenderPreload pd = do
     freeShaderPointers $ _lightSourceShader pd
     freeShaderPointers $ _wallShadowShader pd
     freeShaderPointers $ _backgroundShader pd
-    free $ _dummyPtr pd
 
 {-# INLINE pokeBezQStrat #-}
 pokeBezQStrat :: RenderType -> [[[Float]]]

From 19fa3c16679d40bff797a4a069a2c72991039b55 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 13:10:07 +0100
Subject: [PATCH 10/17] Fix autodoor wall rendering

---
 src/Dodge/Data.hs              |  1 -
 src/Dodge/LevelGen/AutoDoor.hs | 37 +++++++++-------------------------
 src/Dodge/Prototypes.hs        |  1 -
 src/Picture/Preload.hs         | 21 ++++++-------------
 4 files changed, 16 insertions(+), 44 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index d503bb621..274158823 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -553,7 +553,6 @@ data Wall
         , _wlDraw :: Maybe (Wall -> Drawing)
         , _wlSeen :: Bool
         , _wlIsSeeThrough :: Bool
-        , _wlCastShadow :: Bool
         }
     | Door 
         { _wlLine :: [Point2] , _wlID :: Int 
diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs
index 1e978e43b..deb49c62b 100644
--- a/src/Dodge/LevelGen/AutoDoor.hs
+++ b/src/Dodge/LevelGen/AutoDoor.hs
@@ -24,15 +24,15 @@ autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
           is = [i..]
 
 mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
-mkAutoDoor pl pr xs = addSound $ zipWith4 (autoDoorPane [pl,pr])
+mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
                                xs
-                               [ True
-                               , False
-                               , True
-                               , True
-                               , False
-                               , True
-                               ]
+--                               [ True
+--                               , False
+--                               , True
+--                               , True
+--                               , False
+--                               , True
+--                               ]
                                [ [pld,hwd,hw,pl]
                                , [hwd,hwu]
                                , [hwu,plu,pl,hw]
@@ -68,24 +68,8 @@ mkAutoDoor pl pr xs = addSound $ zipWith4 (autoDoorPane [pl,pr])
                  | otherwise = dm w
             where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
 
-drawAutoDoor :: Wall -> Drawing
-drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] 
-        $ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y]
-                   ,color (dark c) $ line [x,y]
-                   ]
-    where 
-        (x:y:_) = _wlLine wl
-        c = _wlColor wl
-        nm = errorNormalizeV 543 (y -.- x)
-        t = 5 *.* nm
-        n = vNormal t
-        n2 = 3 *.* n
-        layer2 | _wlIsSeeThrough wl = 0
-               | isJust $ wl ^? doorMech = 1
-               | otherwise = 2
-
-autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall
-autoDoorPane trigL n castShad closedPos openPos = AutoDoor
+autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
+autoDoorPane trigL n closedPos openPos = AutoDoor
     { _wlLine = closedPos
     , _wlID = n
     , _doorMech = dm
@@ -93,7 +77,6 @@ autoDoorPane trigL n castShad closedPos openPos = AutoDoor
     , _wlDraw = Nothing
     , _wlSeen = False
     , _wlIsSeeThrough = False
-    , _wlCastShadow = castShad
     }
     where 
         a = closedPos !! 0
diff --git a/src/Dodge/Prototypes.hs b/src/Dodge/Prototypes.hs
index 0ecaff646..67051491a 100644
--- a/src/Dodge/Prototypes.hs
+++ b/src/Dodge/Prototypes.hs
@@ -35,7 +35,6 @@ basicAutoDoor = AutoDoor { _wlLine = [(0,0),(50,0)]
                    , _wlDraw = Nothing
                    , _wlSeen = False
                    , _wlIsSeeThrough = False
-                   , _wlCastShadow = True
                    }
 basicDoor = Door { _wlLine = [(0,0),(50,0)]
                    , _wlID = 0
diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs
index f0c539087..34bea19f4 100644
--- a/src/Picture/Preload.hs
+++ b/src/Picture/Preload.hs
@@ -7,15 +7,13 @@ module Picture.Preload
     where
 
 import Picture.Data
+import Shader
+import Geometry (Point2,Point3,Point4)
 
 import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
 
 import Control.Lens
-
 import Foreign
-import Shader
-
-import Geometry (Point2,Point3,Point4)
 
 import qualified Control.Foldl as F
 
@@ -34,7 +32,6 @@ makeLenses ''RenderData
 
 preloadRender :: IO RenderData
 preloadRender = do
--- compile shader programs
 -- lighting shaders
     lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points 
                     (return . return . flat4)
@@ -63,17 +60,16 @@ preloadRender = do
                                        ,[[ 1,-1],[1,0]]
                                        ]
                                  )
-    n <- F.foldM (pokeShader fsShad) [()]
+    n <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
 
 -- background shader
     bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
                                 "data/texture/smudgedDirt.png"
--- input a list of (attribute location, attrib length) pairs
--- these will have buffers and pointers created
-    backgroundvao <- setupVAO [(0,4),(1,2)]
 
+-- framebuffer for lighting
     (fbo,fboTO) <- setupFramebuffer
 
+-- reset to default framebuffer, ready for drawing direct to screen
     bindFramebuffer Framebuffer $= defaultFramebufferObject
     
     return $ RenderData
@@ -119,6 +115,7 @@ cleanUpRenderPreload pd = do
     freeShaderPointers $ _lightSourceShader pd
     freeShaderPointers $ _wallShadowShader pd
     freeShaderPointers $ _backgroundShader pd
+    freeShaderPointers $ _fullscreenShader pd
 
 {-# INLINE pokeBezQStrat #-}
 pokeBezQStrat :: RenderType -> [[[Float]]]
@@ -144,9 +141,6 @@ pokeLineStrat _ = []
 pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
 pokeEllStrat _ = []
 
-bufferOffset :: Integral a => a -> Ptr b
-bufferOffset = plusPtr nullPtr . fromIntegral
-
 vert = VertexShader
 geom = GeometryShader
 frag = FragmentShader
@@ -154,9 +148,6 @@ frag = FragmentShader
 pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
 pokeWPStrat ((x,y),(z,w)) = [[[x,y,z,w]]]
 
-pokeLightWallStrat :: Point3 -> [[[Float]]]
-pokeLightWallStrat (x,y,z) = [[[x,y,z]]]
-
 pokeBGStrat :: a -> [[[Float]]]
 pokeBGStrat = const []
 

From 8108772894ea89ce9fe73f32a70869b2b9713696 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 13:19:38 +0100
Subject: [PATCH 11/17] Fix block wall rendering

---
 src/Dodge/Data.hs           |  9 ---------
 src/Dodge/LevelGen.hs       |  1 -
 src/Dodge/LevelGen/Block.hs |  2 --
 src/Dodge/Rendering.hs      | 12 ------------
 4 files changed, 24 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 274158823..8339ed079 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -573,17 +573,8 @@ data Wall
         , _wlIsSeeThrough :: Bool
         , _blVisible :: Bool
         , _blDegrades :: [Int]
-        , _wlCastShadow :: Bool
         , _blShadows :: [Int]
         }
-    | MultiBlock
-        { _wlLine :: [Point2]
-        , _wlID :: Int
-        , _wlColor :: Color
-        , _wlSeen :: Bool
-        , _wlIsSeeThrough :: Bool
-        , _subWalls :: [Wall]
-        }
 
 data ForceField = FF { _ffLine :: [Point2] , _ffID :: Int 
                      , _ffColor :: Color
diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs
index c6ca735d2..87d8a59a8 100644
--- a/src/Dodge/LevelGen.hs
+++ b/src/Dodge/LevelGen.hs
@@ -181,7 +181,6 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
                         , _blVisible = seen
                         , _blShadows = shadows
                         , _blDegrades = degradeHP
-                        , _wlCastShadow = False
                         }
                 f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
             in  over walls f w
diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs
index faf13c96a..5e2e3b762 100644
--- a/src/Dodge/LevelGen/Block.hs
+++ b/src/Dodge/LevelGen/Block.hs
@@ -97,7 +97,6 @@ addBlockNoShadow (p:ps) hp col isSeeThrough degradability hasAllShadows w
                                                , _blVisible = True
                                                , _blShadows = []
                                                , _blDegrades = degradability
-                                               , _wlCastShadow = bool
                                                }
                              ) is lines shadowList
         wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
@@ -131,7 +130,6 @@ addBlock (p:ps) hp col isSeeThrough degradability w
                                                , _blVisible = True
                                                , _blShadows = []
                                                , _blDegrades = degradability
-                                               , _wlCastShadow = True
                                                }
                              ) is lines
         wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index ad0963400..9797d0333 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -367,10 +367,6 @@ 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)]
                                     ]
@@ -399,10 +395,6 @@ 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)]
                                     ]
@@ -466,12 +458,8 @@ displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
 
 wallsForGloom :: World -> [(Point2,Point2)]
 wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
-                        $ filter wallCastsShadow
                         $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
     where linePairs (x:y:_) = (x,y)
-          wallCastsShadow wl = case wl ^? wlCastShadow of
-                                Just b  -> b
-                                Nothing -> True
 
 lightsForGloom' :: World -> [(Point4)]
 lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)

From a34c578786fae3bcd0ff4df82a098ee01a0ee6d5 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 13:33:57 +0100
Subject: [PATCH 12/17] Combine Door and AutoDoor type constructors, add
 doorPathable field

---
 src/Dodge/Base.hs                 |  4 +---
 src/Dodge/Data.hs                 |  9 +--------
 src/Dodge/LevelGen/AutoDoor.hs    | 10 ++--------
 src/Dodge/LevelGen/TriggerDoor.hs |  2 +-
 src/Dodge/Prototypes.hs           |  4 +++-
 src/Dodge/Update.hs               |  1 -
 6 files changed, 8 insertions(+), 22 deletions(-)

diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs
index f1a86370a..900188f08 100644
--- a/src/Dodge/Base.hs
+++ b/src/Dodge/Base.hs
@@ -386,9 +386,7 @@ collidePointWalkable p1 p2 ws = any (isJust
                                     . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
                                     . _wlLine
                                     ) unwalkableWalls
-    where unwalkableWalls = IM.filter notDoor ws
-          notDoor (AutoDoor {}) = False
-          notDoor _         = True
+    where unwalkableWalls = IM.filter (fromMaybe True . (^? doorPathable)) ws
 
 furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
 furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems 
diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 8339ed079..707e26241 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -546,14 +546,6 @@ data Wall
         , _blHP :: Int
         , _wlIsSeeThrough :: Bool
         }
-    | AutoDoor 
-        { _wlLine :: [Point2] , _wlID :: Int 
-        , _doorMech :: World -> World
-        , _wlColor :: Color
-        , _wlDraw :: Maybe (Wall -> Drawing)
-        , _wlSeen :: Bool
-        , _wlIsSeeThrough :: Bool
-        }
     | Door 
         { _wlLine :: [Point2] , _wlID :: Int 
         , _doorMech :: World -> World
@@ -561,6 +553,7 @@ data Wall
         , _wlDraw :: Maybe (Wall -> Drawing)
         , _wlSeen :: Bool
         , _wlIsSeeThrough :: Bool
+        , _doorPathable :: Bool
         }
     | Block 
         { _wlLine :: [Point2]
diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs
index deb49c62b..8bdf495dc 100644
--- a/src/Dodge/LevelGen/AutoDoor.hs
+++ b/src/Dodge/LevelGen/AutoDoor.hs
@@ -26,13 +26,6 @@ autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
 mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
 mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
                                xs
---                               [ True
---                               , False
---                               , True
---                               , True
---                               , False
---                               , True
---                               ]
                                [ [pld,hwd,hw,pl]
                                , [hwd,hwu]
                                , [hwu,plu,pl,hw]
@@ -69,7 +62,7 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
             where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
 
 autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
-autoDoorPane trigL n closedPos openPos = AutoDoor
+autoDoorPane trigL n closedPos openPos = Door
     { _wlLine = closedPos
     , _wlID = n
     , _doorMech = dm
@@ -77,6 +70,7 @@ autoDoorPane trigL n closedPos openPos = AutoDoor
     , _wlDraw = Nothing
     , _wlSeen = False
     , _wlIsSeeThrough = False
+    , _doorPathable = True
     }
     where 
         a = closedPos !! 0
diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs
index 8bf6cbc4b..8ebaed6c2 100644
--- a/src/Dodge/LevelGen/TriggerDoor.hs
+++ b/src/Dodge/LevelGen/TriggerDoor.hs
@@ -116,7 +116,7 @@ triggerDoorPane c cond n closedPos openPos = Door
     , _wlDraw = Nothing
     , _wlSeen = False
     , _wlIsSeeThrough = False
---    , _doorLine = [a,b,a',b']
+    , _doorPathable = False
     }
     where 
         a = closedPos !! 0
diff --git a/src/Dodge/Prototypes.hs b/src/Dodge/Prototypes.hs
index 67051491a..9f08f0e4f 100644
--- a/src/Dodge/Prototypes.hs
+++ b/src/Dodge/Prototypes.hs
@@ -28,13 +28,14 @@ basicWall = Wall { _wlLine = [(0,0),(50,0)]
                    , _wlSeen = False
                    , _wlIsSeeThrough = False
                    }
-basicAutoDoor = AutoDoor { _wlLine = [(0,0),(50,0)]
+basicAutoDoor = Door { _wlLine = [(0,0),(50,0)]
                    , _wlID = 0
                    , _doorMech = id
                    , _wlColor = light $ dim $ dim $ dim $ yellow
                    , _wlDraw = Nothing
                    , _wlSeen = False
                    , _wlIsSeeThrough = False
+                   , _doorPathable = True
                    }
 basicDoor = Door { _wlLine = [(0,0),(50,0)]
                    , _wlID = 0
@@ -43,6 +44,7 @@ basicDoor = Door { _wlLine = [(0,0),(50,0)]
                    , _wlDraw = Nothing
                    , _wlSeen = False
                    , _wlIsSeeThrough = False
+                   , _doorPathable = False
                    }
 basicCreature :: Creature
 basicCreature = Creature
diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs
index 66f44688b..211436eb4 100644
--- a/src/Dodge/Update.hs
+++ b/src/Dodge/Update.hs
@@ -91,7 +91,6 @@ updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
 wallEvents :: World -> World
 wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of 
                                                                 Door {} -> True
-                                                                AutoDoor {} -> True
                                                                 BlockAutoDoor {} -> True
                                                                 _       -> False) ( _walls w))
 

From 779c858a2ce1c741a1b572704e7a23902fae2b2a Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 13:43:23 +0100
Subject: [PATCH 13/17] Make windows render over walls

---
 src/Dodge/Rendering.hs | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index 9797d0333..e2583f9db 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -27,10 +27,8 @@ 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)
@@ -57,7 +55,6 @@ fixedCoordPictures w = pictures
                                     ]
                 where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
 
-
 worldPictures :: World -> Picture
 worldPictures w
     = pictures $ concat [ decPicts 
@@ -87,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 (drawWall w) (wallShadowsToDraw w)
+          wlPicts'      = map (drawWallFace w) (wallShadowsToDraw w)
           itFloorPicts  = map drawItem (IM.elems (_floorItems w))
           yourPos = _crPos $ you w
           yourRot = _crDir $ you w
@@ -307,16 +304,16 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
     where sp = screenPolygon w
           sps = zip sp (tail sp ++ [head sp])
 
-drawWall :: World -> Wall -> Drawing
-drawWall w wall
+drawWallFace :: World -> Wall -> Drawing
+drawWallFace w wall
     | isRHS sightFrom x y = blank
     | otherwise = colorAndLayer $ polygon $ points
     where 
         colorAndLayer | _wlIsSeeThrough wall = setLayer 2
-                                                . onLayerL [levLayer ShadowLayer] 
+                                                . onLayerL [levLayer ShadowLayer,2] 
                                                 . color (withAlpha 0.2 $ _wlColor wall)
                       | otherwise = setLayer 2 
-                                        . onLayerL [levLayer ShadowLayer,2]
+                                        . onLayerL [levLayer ShadowLayer]
                                         . color (_wlColor wall)
         (x:y:_) = _wlLine wall 
         ps = linePointsBetween x y

From ca14e3675b122c50fb6195999b3c2633ec7ccc52 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 13:51:58 +0100
Subject: [PATCH 14/17] Refactor wall face drawing

---
 src/Dodge/Rendering.hs | 20 +++++---------------
 1 file changed, 5 insertions(+), 15 deletions(-)

diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index e2583f9db..e6f53922b 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -310,15 +310,14 @@ drawWallFace w wall
     | otherwise = colorAndLayer $ polygon $ points
     where 
         colorAndLayer | _wlIsSeeThrough wall = setLayer 2
-                                                . onLayerL [levLayer ShadowLayer,2] 
+                                                . onLayerL [levLayer ShadowLayer,3] 
                                                 . color (withAlpha 0.2 $ _wlColor wall)
                       | otherwise = setLayer 2 
-                                        . onLayerL [levLayer ShadowLayer]
+                                        . onLayerL [levLayer ShadowLayer,2]
                                         . color (_wlColor wall)
         (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
+        ds = map (\p -> safeNormalizeV (p -.- sightFrom)) [x,y]
+        p's = zipWith (\d x -> (15 *.* d) +.+ x) ds [x,y]
         sightFrom = _cameraCenter w
         corns = screenPolygon w
         borders = filter g $ zip corns (tail corns ++ [head corns])
@@ -329,16 +328,7 @@ drawWallFace w wall
         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 ++ ps)
-        wallBase | _wlIsSeeThrough wall = polygon $ _wlLine wall
-                 | otherwise = blank
-
-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)
+        points = orderPolygon (borderps ++ [x,y])
 
 displayInv :: Int -> World -> Picture
 displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) 

From 6cb87b4d28e6fbc5e84fcaeafd9fe48db3a9538e Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 14:15:01 +0100
Subject: [PATCH 15/17] Tweak automatic zooming

---
 moduleFlow.dia                   | Bin 6378 -> 6505 bytes
 src/Dodge/Rendering.hs           |   5 -----
 src/Dodge/Update.hs              |   2 +-
 src/Dodge/{ => Update}/Camera.hs |  23 ++++++++++-------------
 4 files changed, 11 insertions(+), 19 deletions(-)
 rename src/Dodge/{ => Update}/Camera.hs (92%)

diff --git a/moduleFlow.dia b/moduleFlow.dia
index b42527724d12c7a9ba937f407fe3221edae345f4..e9cca2216f76fe359c5bad5d9056891ad60d6405 100644
GIT binary patch
literal 6505
zcmV-v8J6ZBiwFP!000021MOX1b0f#CecxZ9l3%&KjsEU1>y+)>B(69WSL~D@RU>IE
z@tPu46t!#l;r{ju^iV62n&FJt)BIAa%HAcnHJBy`zyTUK`14<WzZsu=Dra}2>Ez=n
zFn)ScPA;aGqsi6B)BpbbxA*S!FJHg=^W~`c6aIHKD{fBkHzs%V>f`D4e17|<4<9~%
z{>;V?cg1`<W8=|1yDLBZUojpRA8^r!)34v1oIJn4Wic=4y~Vr5d_EhU-_OgFNpVwt
zJUuTie!H4Y?<be1)vCq1i|KeeJNZ<MKc0T|>*DA1!{S08maeqs>bJ#Jc|I$P-<mJZ
z@yGkkE`D3iRxf;WJG~p>lKI2!izN-$q5nTyvsiV9izZiJfAx*}s=B4c8&B7&yU|7=
z^P6IJHJZGXgP+d0`X~f*LJ0ggw0E9cW#RENdA+#v?TQ<3SKMs7;zoC8x6|2tR*dE^
zMV?Qm<Fc4kQs=Y#a&tL%7sVJKv31*u*u}4-`Fz@P|GyUFyDl53-u|L(uhrbE+30e;
z;x4UdxXR@N{yDlx`jvbhUCyu1eoyq3R9AmUboEc8yV3c$th@WsWZv85ANslc>Jt!r
z#M7@wK5^C68lBLkD|M+iaY9%3qs#KH<zZf4({QEh#j+1=pZn^%$dBf7bay*09@cMR
zby35$iphM0HmtZSFMF~yO{Q{E+`gYr->=w-gp#J`|65)pw*S}D&)e7$iMg0gCb%EO
zq3>^}sIPZh_6*fqD;PD1#mB6iEpGMOCv<wUus4ej`DC$y;@MjT?&s6vt7lJq_0=t&
z<iCxlpD(V9+5F`F$+y$rPoLm8g7MMi$J2lFWmQ=H`0#272VSUi_!Jk|LopBoA(_>y
zTKe+yY7%jNzA9lx+nrpE%P&&64N``}Fd+v*GrO6*a$Me=T})?_mteWiZ3QvG=e^w8
z6K>;%KmUOUS=Z(0>U!QR44CJA2qTR;tBIuAO~h-Y+!mLY%kXezJDhF!#mvj!Uwlfd
z9$;ln(<c#vq@{JM@znQs4FS~}JJtkgr;~Y|EPDUsR|JRS2fU?Xa(8-iH-8{QfjVCO
z>Oacyr*b~JD4yH2*Wba5C#?2sam!B`S8+m@txv70Y6g0M3hTU%leG+-*2M6fKf$NX
zL?Ljvn%tE2UuikHzp25L>wI6GCu#ylAD;Zg=8gkm9S1n3l(7S;nNR6DP>%EqIpjR7
z@M0h>^C{g&51Z@aKpeV4q5QL->_Cpnf&5a8$KT;S&+ljDchm8BL`s-_N_w9nm^PBk
z1kX-odrn0}M<e*Gh=CGJ8e>z&Bb-?q<bc7DL^3T0N`+TRqmuaTb&E?(j!TZ&t$bVD
zmD!1G!HHmCqR==1*z82M<wRt3Wa60+9tOfP?W9Z@n|KCxAxTO(q##x+eC@;Qq!CIV
zo9yCDG}Cq|M3LE<9F;S9j8A@=7xU~@w&7Jc7&8!#S>a^%E8FrbD%!7DW`y+v0Zb+K
zD`?d1LQ?Q6fJj6uI?qt4{YoF3?BZ8&D>mwICi{|o^d+PD92GCSk<@Mk@t-v0MljgV
zZe)vYMEBrEJO?oVhk>OrY2Ap^l_Z7F$`GFwubdqS9$qJQBk`N;;zktnekndN*`*wn
zOZk2>3Uyj{1r-2g$C5lgLE|t$?_vy?>{YhqRZOf`;mkV3>!HX>q&+-AQSyr@IzK@h
zj1WXoQI|-3g3`}6yEzu_yw7LzN9$OAC_k0szn9siq<1L{RhI07Vk#e{Y|*ROK8n1Y
z^#f3hEPUEBFC`a}@L8dhm-HHuhzYM#7kfo-vfH`5TRBU~F6F3P%D>PkWOuTK)R#w?
zIRMR+a4Nf#ZMhQ{UEZacGfE7k#1JCs2?|MqN|JGOf`T?4sBl<^*GY@K`q*SQccQs|
zu6g-n{<z%9kH!2tyOZS6iDf|UL@MTNK1tc0JMq!(#4@KW462ffr1ip<Sx=JC3>ssH
zQZQk>p)8a)iED=Y*kream$V|Eq#Un1`A<2yEa|V=r=<2Nk~1DMUXp>y8Lut2HAXkY
zgJ2-&<l00;3f)p(XwmIL5><Is@vNmYbCbHttB*}~tMU@dDKD3u%5gcB>GUR-d!^5L
z5tGG$3VL#}*EZcrbep^|j0=zh`~s7<$qUUeK&j*m5q?<V9A!w8w#oOfxo(k(*`X6r
z*@+}Sik}vjKhdX@9ZB+Rmt#_sVaSc~+w>#Ro$-!oKR|n{P12HK6r+L|FlGqUNKTDP
zktMvXek6W#9V@zEsh}$-xQ>i%r7UhUy~;MC5zY*C9$UyY!YQ1{&*ki9G%3c<JPAB{
z64^sU;=G|)(kDJNG0awiTwq!8%t|Y%wj4GVd{fSgHgj@0x|k=9dZItTZs+?}fzZ*B
zNJoFgmwn@g_I^B?lx-X140tcjF$g0|aX)+cP^_~buMzU=Xguy9WOeYsKDznvc?DOs
zD&Wcf@fW1dwFKWiql=y%h^-d;6{B1`zKwWQP@gLuiY%S9XSA__Zk*9zg&I|?y`fhb
z$?@p+?0PyI{ecfG0+)66YlWWs)nX76(c_*>$ld)pO}8jdH@1Ua@ZL`dl`f0fCBnTQ
z&@9&_4Wbz<gkS=cToB#4lvqz7egGiGMW>9TR$~Wp!F9K3ojcK{pOur#7o_i<_gTAC
zd1u0nZd`zm+H!HbdOvl8Bwhv6CYNW$Y&QMeteiqbUixfYPOjENGaW0U75sIS@WlFm
z_rjw;{>#ZVD$&9l&ZmKa^5p4X@vAT|o`srUhQ%*K^DjTz-<4bHNzru=if)C5N&zgS
zRdl0`3x(963^6hrj2wbwr&W4Iuis~Fl%^G!s^VK@MbC=<r08x}if(#H-gxkK(bu5T
z9w>tZPfguMfgnZq)~V3epai5=^rn5*_FG70!+mClesp^7V)UHvO3(Xfyrsv#B7jSo
zqy>e5-9sSiF+vT2;%%!*vgS%8R`aH9)~r-y5UM<Y%<lZy)Lcd3_MPc@bVsCOS~#vN
zDixQ~pDU)c*MZm(gi%AsI6>$j*_qT4dgDG{F15^~h6f7-US&-`GEFxznr_stG(Eam
z4LCY5XR6|wq#m6!r*&u}&~^xtX>F>S9-BN7*R;vnf@UQ_Wq*F0S`OkM9lGeFeMk!7
z7aCyFwhsxdLJz7$e-2cRBZ6F~lk0iYF6#-URYlmQq>x$Bv!XvK`mWr$fF9=Na?1^I
znhCopeD0QrqtYB6fI8QTW{iN;flN)RO@T!BJY3T@YnBp8z4D>wRc@L&$cnzNip~#G
z&qWWzge>Sqh6>Wo5>l4(?VKqt#Ss4lT~SUbZ&K@d(>81Qfw=~=AQ5+2&2u8|i<;|Q
zsd@a&FojREQ&lg%a%mIp06`EpVn}Ii`n#80r&jT%E!Hk|l1o|&60(jT8)lF4<<{>?
z%j4_e0;w!e`=jGJF=&^PE0Scx>A6Ks65;rYZ=p=4X`i+9Qrr;vE#4RxI;;9|sk)6y
z!^zZ|{%!fksGK$FdvsY`MZ+YCJIyB^C`}yFT9X=i@7$u<$pzN7ja~bB`NvtSt~c(n
zM%O)&pgKbNLNB*}*DM7sflxl0EwOfKsL;2IDMK3vD%5m!Mi0o{YkE^^|1DdYEn6AC
ziItICvocNgCB7QZk#+<oYQJ&MQda^>FSQRIT{%yD#zuQtH6hyM_4Q5rthWY^+tBs7
zu{FqeVsAqS*l$45r0UTHdFTj*Gu13T%M%Y3x4MeGt&)@n40%C1&KEj)zQ1Xk^@+d`
z;uxAlo;Cf*G+jsK2$JY|JI{`YA5nnuxuw*XPCcEIB7=pbFr5<x>hRhopU&CKCOZy!
zhCD>=h$(medwW^T%iIQ^oKTwh=c|l-9?aPv=}zZVl<%QKQybw2(lDR2${Vy2l@sBV
zcNQ2giqNj<wO0xAQ1u(EStpquNc2F;uU%&dUGi`wZP%u%o~g#>elzEv4mv80$v+9V
z(=4})E;;Q*0XkV1&A9b}?w4z4=}^m%aiJuX+_dYwTavqJi*;O*Lem|BZAn`L6O;_6
zQdXNY+}XmcZ#Q>)nBs1ahh=n~>w7_DcVGvKGm+4=pd7CjazGCSGc;tJh#o+v4265x
zUzb3b0`1H_d&GfopfCSndNsPp!Eowe_&u5k8FUtyRGG$n%fYaWE~;L9fhK%|ka8>r
zN}}>6Az&ap5t;ZQf>>c>W$?L884@>c^W{>`3<mD_NMoSB_Iwqush!g38YNz{rQie6
zauq{+;zi5A^$h}785JArodMVQif-nGlalgLRwiXif-pBWNFuJHA#s`n1$7Y|O&#aB
z^|8q=_|;&rY@ZLC78$=D6@L8=?{|JbE5E69IfK~LAXbOtUl)i-ty3AqZW+Y(L9PpW
zpkxHJ>f~Mw17W!h?galv1wl?25^Of+;p=*$Q@6p|b|Fc{!no9<KU%lcBYLH3Wdy`)
zv$)T+V{;#xk?Wgd_<RJea%aF*#{*a4oYfTH8J!fi3i&7pgJNsK3&~7cz#6@|Zlk`G
zSW36r3|Ef|uKu%p_@7S*LNZX@Lg|r4UmR*SY@Qjpb(|XAq|ytN>R8cgofUy1T1yE-
zDr_aH2+B^VO`GaFLDj}R)-83C!$7Jqm2B;?KU134Sp=->3y{7jNUlD5iz!wag;e!!
z%a82g9OiI_noF}MC=%9gsF*gMn{bi?*6qtlPKa>jKze3dT4xpGn%3!-bvYW&Mh5mU
z9PVsnTzrjVtdH$j;Anw*=~3a-7p^@Ls)SHU>l^E~S6AG~!y;&bB!W|8k0pLi)z;~+
zDa(gD&Bw!U(X8kgv%+_4Rs7+EMw$r^L~8F)A*CGxVi^pPs?cat`p~{ZBSWRr7`(X_
zli@?xpdCog*3*bB#)NO)W0;N0+YOA?F$*V6;j2DKz^%4ope(a#J2FTTUr0hNqwzhQ
zCh903UMEfE_p!-twbKHGdX~)BIhlV{$^8GI=1*__QI2nOHa~SXA2gFjs)2IMLvAGQ
zE1loLtHihB&>=0NM=Iw{$u)&?94zE;J$z4dm;?_6$2@H>PW%SD9S&<DvJW{fAM)dD
zI-iC(A^VWz{Wl?9MXUmxiQIp)?IU3o-+%M$3*<U&SEo}Ns$pcthH+%l69p++c)^o4
z-!$y8W+hP8SL=|f@M0}11)yzLE=(+KV_U_oT1~z2W+_>l(;shUltR>z4eU0#s^sAq
z89*=O6fq!6CnZfnGggK4q|#<TYz!>eY;a*)7MA8WDisKwRm(9Ccns#~m}hlqHZs}B
zbTKk&S1H!$?hDXNnCdW8r=@l$NwAOvCiGu~?miV>Ce5(+vB!=XR+}T@Ba4WCna;+S
zxt(uYc~wh1GLDW<Ei8{d&N1;8V&eF=o2M^Or)}s1n$80*)B-3&aMd{n!OGi&V6}0B
zwM#8j2mGcb#FdZh+M?lH3-Gpas@lU^fX>#%9FTRP$sjZqoaTvoOAN4lfgzn0dtzTa
z-XonSsTPLDidUmUy(4ZC4GWo6ode-)U|wG!y<7WY4~2|?C{UFT(XUcc4{6dM_kpKT
zIw$smjlfm4&(c$gWm}na)ePn^#BYT}@di9wm^VvEpww<Hj60k*FTo7>M;l{-0wf78
zaE2g~k^9l+WkP+Wq~5dE(8p9IS5jl3*OL3sRwg%k9kQA6J>>Nt>l1C-`Ac+^?_ptP
zyc^PRL#ceIXLdHFnQ7c(ZILx6mU?AcN4A1wj+UaCY3nD=W+sPAd=Je``@x~+eH<Km
z88APjKR8qiNpx^Xfr+l#)nN-KhtZqtHsDQgn@<jp>*VmS<@x<pJ~B*xWN63>`;e%}
zM}}KJGSqM|NjF2Yv=uoHZnO^!pu`rSFj6*qLIH}1Qilk=Js9>zhI^N~WnqO;eT28n
z81>C2-1KhiXLWRuelH5p&AxD|SuqtkffE!7TWftlk1lCRLemy&qg($-vfpN6AP~2S
zm7~C1laTGp%7}A*ko*K%_P~1rG87=mv>~t}XI}}T2sosjB$W%v!~t+0JM0qw3PfVL
za`wpL-*3m$i{Enmn>zk|Hl0f6_;>s9Z*&hvFXP2J`4P#4b!5*q1LcUW-aGCf*mtLN
zLWtV9$2vAo41q=aK~05ZRVQ*jMqHwb==nqrg5M@cjUv%9yA6W%A(<HC!f<oT6i7Lw
zJe37enHX;N!^Bu7@U8@zjy4-(!ZiVXYs<nOhR0_M^L8!Fy2<F<Ffq}k`NFbL#-)XK
zDXZFuf0M@0qWcG_htx7oAu7>-d!4dNy?%o=>pZJyJwv^kXjzIdOjRxREtUxPNp$E!
ztT1L|1M^l4jE%~(`CX;iY<!wcfdxNMI;cQWdSPjTBo$(dp=Vap(Xuk(b=pi@51Z^p
z+a`Rb0X^ch+uzISO*x-E<jh;@%$sG}NTtX;fORrw-nN{1i*CmF@&)P$``(RQNik=H
z4irb;X`1OJi2ej6J7H30-WvB<)3>2Q`==%U=UPsO--me@61~ZiQBT8Pm2vAq2gWw4
zMjCb-82dvhZ?g=*YN*&mjSJ;%q31zH9NzX^-Uet3$m(@i%IT2XQX7VVmT?<B<TkT~
zdAk*EyKP!G{BTeV#>3oeMf&TUGQq?kjv)Zd75DprVyJ<OFieM)7HtbzNKJ&bu7w#R
z)`({l^L9bZZh3bM9L|I<s!P>qVkk9^0TP)Q%SAQeOD8STf5n6^$GnyR1Wu%F=@E5k
zIH-jzFns9DzLTv?x*5p3wKAfINJ$&vN!NYKBSgWh3h{z6;AlFj1VOs&4R>k7q?+y3
ztV5I$Oon7ewZIa^^uoG8wl3MathX+3z{W-PU|iy#|E~5$DF{`T28;~jj}=$cB4g5;
zm--FXTOu+Wct@(u!qE5)T8iee1?uDx$Zs0D?B4|B_TmH+UA#?$LZ$RnAt-dx?5;PD
za)v~GthlG~IU;3ILJynk$bMn%^O6L=&5{I_OA=C-B>Yf3Oz-EpAR%=@0`UP0K%~K$
z^m(9M|Mdt>=ro=-AHtzsu(TW?Engc@S9%yFC()M(CWI0sSqkAdg>I9{83K{^R`sTR
z)^fIi)`D&n?{h;xhY!!i?dttJiO6_yXL!+UL^KWiG1kqP1Icxv5*hA9i1dsxL}QPk
zsH(DE2KFJ_RgHk8QX*(OuTxA~p<i-MWKN1~U3yG)?TnJb*dC@uf+OZ-^qM?zNh5}B
z@==tOawr%N+%kg4maw;vIPYbf9cQ|U=aFeHmp``Hl)jRmruVapJo9`DGtW8AU?j!G
z06^rL`7Oq%(be)~->o5&YpqDy<H@)Z-ck>_=GIY&3L*%0!m7j(YSS+3NyROMR(I<+
zy{{ag?rnf-4>>?Rn6h<Jc2^;}&~r&Or9y?WbuF#fld^R|z1K>ymP&N%lu_i{c*_aw
z!VgxCkmq`gT(<sdN*cSPAk{_}tP2XN0%L<s%N3y+gaKwm*)XJfuQ2^+bB2m;!D$cM
z>(<B(rjKATN2YrknSMX{gz?5ScXFo>OCPyiEFzB_l5Q&`weh0^Bw6z?H&a`lw5U%~
zwQ%6(r$2{+#zS!zh6hLose{s{eb#y(r62vA%t2{}j9+3>yW5!5iUZ*oGfY`ijeRm8
z%`gBuUg^H@dJj0pFlhAL*-lF_$_-;eTDZu1Y4OVO=-VY2le_H@u<}5xi)3C~;{!t~
zH~PuC@Q8r1Z|kCbC*wlg3xSo;k!5t5AvN2VWcFpp45?Q2U|(oF4^=vuw51u8uy)Q-
zB}NshIHSUZUb}IoxvPPx-(hXpmjtJ~ECq^ac&KV#i(sBrKZ|T$-ky1JQR(zujpDV@
zwd3y%6WnV@?Ld&Y=BpaZP>G_NulE(Lfg>t)nY!q!mwk3it-GamBySR?)-mw%eF)2`
z_3o+lZ|>*QzfPyKcRv>MYkcP&qJa76;+JAPzI*r6=h6J)`rXg7(bZKsqh&b(pS&(i
z(%CubwqP>Xg>9Wn)tVkEj~CydjDVTlybwAaqcMaQGJwY+N6|#18V3BN<vMKMX3bi`
z1jhPZmQq8nQu^hDqCCtfBi)yQwBEmAMjeo@jb}Qv%7YzXM3@-pT4wyCB*MACso5cv
zq(Wkt+sh`q4c$~y=v+W@v?%xISy^W2ni{$~=8dKXYLk)cE|9B>r*Qf51wvZjN+r&w
z@*><?H}uRHn#URVRYb~z<;FeMrBS(~$`)#CXi2w%u80GmWmrJY%)W8FY7a9t8{I?!
zG#>*{M^tLSN)q%!QUI)md1WGvS~tMj%O<-4R^ylQvMvMGqXMj`k~!I$9<gF%sg(;6
zW=5>rEO>U&tutTDx<=5YlR6Z`oYz2B-3bswa7;NLBx|KiYM!X3ebzFpE9oFC-I$&s
zS3K`6cJxst&pU#SF1odWIz+t(BL@IXrKA=`Nk)B<G?a`RI$r?ERMO-8J~r5mUev%+
zo>OLe(W8Qm-{HDhk#S>k+=y|W<$eHy=}a%WMc5eKI0MW{A56ORNvT_aS<9sfl7w_a
z;s}#gSEzAQ$=y+7!#3-x(ZMJi@TIcSWzcwJrJxW48hfZTuU?OfhjRAyyXpo0cQq?+
PzJB-r`*o+c6RrUO0?4ux

literal 6378
zcmV<G7!~IqiwFP!000021MOW~b0fF0e&1iAl3%%4H0}tqPT9^$;)+vo#ZLKAMTujH
z#}ug|sa?wt=eM7347C!e8P13p@Fu9r-X#~B9+1<QuhISWpa1gv?fC3dF`JL3laJ@X
z`1x5extb0~lk1P?|NZ%I@7?)dzJB-T;b`zD{O@`;xIM$)n9S+b$Mc)T;_go$K79WC
znT;RjgT-{l#-n>SFFyR=U_2gtz(pU<zkYXi_WT0F!D2w~E#Dn17PHai{h~OV3~q~$
z=a+-4->zrV`^oUUT(w+xH62f9XP*Y+kLO?gy8Jo+u)NTRl`Czy`rY8VxSSP(-|8>U
z@yGk^E`C?c)-QZ}H=U1g$>QPe#gdxq(Ep#US+1JnqRI8wUwxy#DsO4|#?!T`ZnRd&
z;&w2*9!*}#!B1ygeiVW^Aq0LL+B?s!vhetsyk6YpZpDpvD{i)1aijUg-E_8?4MvNX
zA}^=YaWR;bQWvxPVtYCBtHBr_u}#~G*u}4-#bVlU|Gy5#^EMkO-~OU)uhrb^*=V>~
zaaUH<TxIxxe~zw_ekGqr!^O?T?}@&W^6C$XuKsB>A6<@%s=FUe7M)%Gp_|LEKLNo<
zJpFp)6IWiX)(H(=p$ol@6S}@14U2ih!@Rnt=1MoqWgnV8_w{v=AI)$yzZ(x8Hg92l
zQO&gmlf?*a*kE1^JF+x&rgAd4d%u{zU$YYlB~35?x424d|8J(Bcd;W9b2Xhza6cG_
zzQ3EIzRq{-8OpcTV$>iOAG2b%ywz`?qSLdby;*+9XUh!?p1n1|{d{_S_3Vi+zq;j<
z{I~J+^VQ8@wm5r#_U-id^QUkegYnVu<N3e&sw%91e0Vhs2VSUi_!O71hhiXlLNcq@
zwe;oZRVU)|a$UlVwmZ2V7hj}s8>IAwVM6wVW_CMy#kjb=xSGx;FN5VSw-v+$pZ9WW
zPjMSJ{P_<=$hs*;*EfrLVZc1^LKtb(MFo;-HW9CpayJ+bSHr`#?Qpi`7qcjSfAJ};
zdw{hyb)Q54Nh|Bt@znS88bGzdj@5;<)5)Sr7QKJ=D+Y(-2fU@hWPW}&Up$bZKpiiC
z^&iFfQ?VFb4W8Sy*Wba5C#>>oajQ=mS8+mDtxu(@Y6iN83hTU%leHQ+ZNTuHKZQ@*
ziNe6)dU9J-f2GCb{<b2f+~oVJJW*X>^x?@*Z0|TA)^UJiN*UXen)#Hj1La7+lta$L
z3NL!nGN00Ybg;QL4#c4=6v{vQ$qwYC9LO(&@%THu=f(Z3_-;BLk4Oo#Pf71n1k*;6
znc&%}?9Qo(Xf%S)is&i9q%k%n9^uT|AO{RW63MjeDHUENMJ4guYlllr#wDlhR=yp~
zi|j;p;6xCZC^QZLHan4BIT0C+Ogt09Lr++yos=oDiDzJ!lBAS<0<l`*Yad=GMJQct
zvW+v*OxqQRBC|6&DQEJCPkveq7TK%p!mDsFrY9V;!pZDccI8)8v|q8z2<v+Sm`dzd
z(5Ty`q~KQoBN46WJVT}SD_v}|jbFj7*r>yq>`M;Omy8w*RJ`m)Qo9k1|D+)|f?z+p
zksZ1b-GLkN97GQs0!w4kx)G;KNeZ8pK0Yg6IolIFyiV*!;y2mGjVR{*3O+H}rJR&Y
z`F=7Abz1WQ6#!+&k{q9)ap<9UF$PTbD!cM3Cf2KPW*x@sp~y<4Jv>2C@{1@sKS3Le
zA&8=)E|K^IrJHTGb1d9>pU>t`*0KChd@9C&FS1KX?@}15EZGOeR6a`Cp;xh86nQ!8
zd!QIu__SqSN-ibgvqC8^=`}_oCcI8v>=nJqcIWbL?JOm`l#_BP|3agX-N_D8U!G1-
zKr<zr%I;)W?!-lxcWLH~5<MvqLL@ywAxTh5GLBAA(8dE54(sqbX^~eKn{4M!G}q5H
zFQ3exmOJ@zu(-+YBsn^<41j9=6>~P9r0mX}_-J=xnNt>eWl2TSdST0~CrM}qjj??x
zm@wW@7RsB%HN#zOvR%SUT9HpuPS>6Mr<e>2`fK(nseOv%jE9VuWMFc}Ylm%((GBq+
z7zjGKHW5gnUCIkBx?M`5Dz6gHS~@c~sjIxY*krpZFR_~Pa@nbzmQ$HdZ*#d<`kWUr
zS@fu&Cl`C|(w#)N$qU1{0NKMYFln2-&<p`eDW{L&hZW9IhBRrLd<UCrhfK^Korua#
zB>7SNbTIshKBeqPl4rXdlbQ@eZj9fhABpaacTD>p+FNasmJFj96~urseV|5iYE+6W
z;cfII@tbQ|(FH37T{*#ZVr(nL;4agv>;jE&W~lSnLaq@`;Y5BeX1AlsVEoLJz@sOT
z9Uv0t4Pi;2_|U{KTMBZ4WyLcqt)$v=*jn&yu^2R&li}!Ukr?$ve}L`I_pJh<qmf8U
zf5lgQ<CgY*Jem|u8{-UkC(bblBTI2Vd-+govLCMz^6O|kZXslS@W3Iu`S5uKSG6wS
z$^P*dq|TKD-yKI69X${`E%qCXa_#so@T#CbS2`3~Icd+)#umD9L4y@4RI&1gUS%Z5
zqq~cn>1^}|KCl?LY_eZ#^xUr&gE0|3?#YDA?=NY(MRC5h9c&Zt{e+>?a4;KUxc38^
z<*KAXG-HJjOn{P0qC1x|))N>%01)G%Q^rxNu>-l}y4$wSooLf9iplT=>3i#aRxVZE
znQ)_97vQ6|T-~kTPt_oaSA}Vl;l*G!n|`iWP9Y*MeK9U3*PBB#9V?<S_-iTQiS>W}
z!lOU_%h?So(b5|(rh$R-?CD?et1vH~g^FK><u611FF)GfwOi^)(RBxkZiR+Y0W73d
zbfb+6h18%7F)|xO4neZhD!rmt@3Ru6X$7XN_!e2wv!XvKy4#ncn+}pU9=u)lHK?=)
z${@j0Q@2qdNYTA@Dzr5y0jU+eZl9I?7E;-8pV^_GoSwTFJ?Hz<^DY{1>G3ZK;8G@O
zL1Dn|ArSQ#q5430+iH@mxe|%hyl$HnD-{`pG7liLJ3lowS5a~M-t;`WBT_Lf9M>h4
zic9Iw6;s;lK<o&@sJ>&ILg*mbnbZiqcAqboTINy1g9QSwvZkMyrkfZ|H)>y+9^I@4
z937Z5WpPbXkItFXI<ygJ+Xu<CHf2qZO`eFW+hk=yvyz~)KR-<^2XT}RU3AetB!%!x
z4KQijhlEz42UVg!2P(%AL9Wxu^}KGE)r8WjBy3Ys$gJpD(VrB3U+!E$2Xk||<%T%T
zgxxlLZkLFo(i|QFb*>f77y+pRnVMAF1`_S_aCO_PSV|=I%7>m;xozekEBc`-IzLK1
z7aa@}vY?k4Do8s^NLk9abEdcyef$%2NjagsNv-E~+pOdV<{HeBMBHUH&xyD%YOeRC
z=J7Mb6h6&PmA&}NrA@d41VP*g=u=*sqj$&GUUHpU&Fi*VxztH6X(^opW<5W#xIN0B
zTfZ+&kFSXf#IiswkdEubfxDDkkt7>V&@F0`2uE0a2c<G~`>dpx;)V!t@y58&S=CQV
z)ooNNPNvrMZ;L-h#jH->qf6sTDke$%X+H5#Y2uOAn$*a9=avmmE-<%k?b<JkKQ0<|
zy>^cky6%Yx)lsA`^lA%u#Zu4`DAGr>B{nV%Rr+>0X=rP(LXB4!^nlD?)1OlLZ`sQ1
z*vj~Atc={5m8r8Y@fCTFw8I9jm96`h+LBOuseSP1%6Z~6HrmUw5z!{Ev9H@_wKZ_u
zhR)BetwD|_4i-AVVFwg-svcdGhmKG<Q_j<~Jn>+0t4r){m84u?$PLnwzR<~Y{&m}|
zP6h^uV`v(A*7Ot8bRCr=NTTP>TstCuOabC^OQ|oNdO{~5gQcV}p%Vq_@Y*Jy(Ami*
zTMl}LJV@<?X?Om6HykXA+zOwZRGK*G%Zz*;&e<LDPU}>Z@1RRl8{vD>FrT#28?+Lo
z6XBG17Kj%`Xxa4ItAu%|>J3(`lT7y{dLZRDt}_%}@^CC|H>RqdsmAtxGv}X<8kNT6
zpM=|MmRm-bopz!Ct*nb?-1<QI%eAv~sAb5wP!dXR+j-tD$z8X_Dn3b}=?=j*q^*Go
zN`_N8tIZkiY+*LHoVx=|aW~^(8C~o8UJ&6O*q-7{Bs483$E&3r(0#!S4H_r12hb^@
za0mNq1B3}^Xa3m}2Eu{D{D<lF=qiKZ)L{5Mnh0rVZl3}sRpv6^F&dW9mDMZXAf%j)
zfs&}ci6&JDPi!W>k5Q~Jvb6Zzro_ax+kCl{GlR$-{SYGcjR&lFP3@FM-zf2#4HX|4
zE|(zM6FFLrT;E{iDx<)$-dp4vU)IgMa8go2%F3j4Nf3s|21!I%)F)z-pr9^-sHx>J
zw=Oo>CV(}FmhJP2(;^43Cl$bchxfa<pB3Mfx}2lf)KRPs=f5tnky@v65WC|bwhM+`
z&^;w1LaSEp#V`<-+u%;{Z&VTFgdxFZYcjsJM><s-tn3$(R4t54J^G_fOFc%fRIZEx
z@y0anGws;khvvxj&Cz^52Ci~%fvb)WT!nL16TUM#Y1k^{qZ|aq)`S<5nY00G^yb>l
z`%+>h-)eKXdQ#!)KZ}R|`Gi484petgd!*49hoTLe2S@HaPL1wT=_HhDS<-5q6@e#O
zO9_3dY$d)3%1)?lJL_A8s<nHpTIwW+o>XBp*~W8!rZlay7_e@xK>DH}x%}uYrdVZE
zq^kE@e`Js6Fo!eLT<TU2P*}UZV%m6a!ch)bcPK|W0piM@^vpIi&nm_>t<w$bG91oU
z1`ZGpx3)4azREGy$+j$Uv_ReTsBr2F;~oiBLa3w_j#b;MDsSXr5j4akf>UdcC6-Rr
z)a$P)&4)Y9=fiK&tmqiC!uM-c{PAET&4dS{ws)wI()Iy^8N^5>Hrkd%v}<f+sCXLD
zn`<x`KJ*RRp5$yZk=Sxr`1W0f*|@x2WVDH2IB5=FbwLGgwG};OnN8c1L6Z1V5^5O@
z@!>RANBQtNX)eEuO}49^79iBKY`)If{FBP&{|7aHdi#%Je3#StsnhwOnKV-Mlw%%p
zD{)u({1#p%z8Qy3X)$`Fdft?5Qz*y5QV!Ss_cV=3@KABg({|&;Z?N6zuofcwkkj%Z
zKhCC$X}}5Dha~U73F#{072r(d2Ao}=39I-9oM&Gk*J=AYozhT_Br`S)C6k^=NYTOz
zp0xX>W{(vsfwI0@hg5|Z8+j=JZM$+|ZfO(WDsI(k>W()n$=aO$crybPqK<4}zsXf4
zkH^RWdLgHX16evLX&#!fDx@csHiuzjV995L3!AdAG{sS=K<TU+j(NZ%n4@E!^`+U!
zWFynY$f$j#Sfkr7Kr>;=!%&@;+?^!BQWBWZfDzjJRCt**!`j6jTV_~oM#LwEh<};R
z#>3ptx2wFWB_<h1$EOxn2OwumyaP-e-*@x$1?sdNeL(Yhz=c`>Whh*A&Oxy9Hes+@
zyTQt(7Rm#D(*SYh<GLm^oNEEzcATmXuoj@TbumX|U1&B44F{*GqTUh*EMLZu&WZ!E
zFCOoa&XZIFM`KB>(W2fFH;IOYOsdX6I2)MP7fA2dzSv`7BOnq~<pcUvO6oq%8st7O
zHA?5iLC_Jnvi4beDzR)TlP<f#976oYkSN}OXAARY83~lyuZ3~P)8{3a0sm-YED%7F
z-~wp~Ml#|s+PqAtuawk#)(Cw}S#l*c0=<UZf3`BY(d(GajPD??|5%@B(@tQbqkIob
zGvi&K#v4lILp`&zG9^-~+hb*sH7A~WWg3UJf@F@CqM2#xC(ULi!zF%zW~TYzQ1dPh
z4!sO9Kcqi6R7**8a7e&Jm+k7XgOkJPO|~2HCb-Qfho^ON_}Aj{{yHBSCO<MX<b{1m
zROBPWogW!$IGUuJp=sKR90xbr2MSPP3s8uZ&4F-$VnnF}LT?7c-pFw8Qa3CtV^kmE
zEpv?eW)p6DzxA^^x=6nh1!!kqIMu9}lAOQ^Lc-RTJWJq`mL$||u@c?-N0$9269a*{
zO{^US=9+|TU)F}4^P}V^(6R&G6Of?*Nv4Isiky8Zh!Ai{J4q@Rl8FIu7dvc&e+5Qj
zxpMZz@b9<d>D6x;|E9*j&&E^fjDL5Jf1`UaI+-ul%8y7UEJ9u)<^$!3uiiWEAlP@O
zbixp|c8^tTo(O?O^Fd7+$*NZ5e2ln6718sF41(WgkQzmzW%dh#^)Z<k<HC4z%M?i2
zr#zJfQJNTT4#UJ)Ch)EVnT{qKW5P87eQU$Q4#vl43-fj@%%<7syD%})rTN0LP{yT&
zcPXpdh<{UH$b#-4r0!G8I6+jR|Mog%mwNREE7o~d(t3t^HPNsX!!T90*f&@r+$YhY
z3$ezSkqyjSF)%hN&*t})X0!2WHU$=ZPwAinN$G{936fO67JbjGrlVzL!t1n|whlJg
zj<!wsOapqtX}7-@)7xS(d&rr$)R{NSw2?}Yc>wEV&b;k7^A_EV@#PED5%#?uxsqbe
z2puSnyi=a0dI{n`LD5c_l&QDcO;$8+sL=mu$pN~C<Kg#V;DtnYvSQWK5Lo5F^{A1t
zjVh9c{UT$3EcI=c0ay(sov3l4zAZF8$cWS1j_cb1Z2?)m7E3vua$D-d5YRAhql4sT
zwlHtE#BIM_>xLgs7=wVAd#y-+ol_>57>r{m0_KYQ!-!(2gNtIA7Aq~<7P63<7;9Yv
zHAbuv&nD*W1~L03-Z5}IBfh9GRilZa+&BUxGBK8ma>SQTTBZMr5nqmZEdeMvk+z{p
z)S=;^9<o63p)>tXwle9aAn(`8hz^jFHo}vx`;=#hf>{;tf->M}JgEdhy6g>iX<<^u
z_A1t4lo3pZWJWcFC5q{#b%AVMvUS;PUEqj~i|oL-#6SOS?Tb>xOsbgyBg6b-#TE6)
zn6&1ldV|%Lh|C7wk!rFqG=GDZqIqlxb@B}4Hyyeh-U#I8>I4&Ay-kxsrSw!HD0I^7
zt~ZZz`ow*#xTpC!B4t%V2b*h2e_`$OngqYgngo?=5>nSB{4jW!-Y;@RLh6bHA_NwI
zkp^ed=ZSLN7bMh0r}4b`5Dx8vrR4x=3EP0$(!(q{iM~WIA(SA=QV73o=r);LU?9@m
zt6sOyO42saTF{N+eQxRJ@Zq_-Tfd(t5jkGmTfAttVw#4-nCoWDk>t8ii41olAU$IY
z@z^62Rb{rzz#(M2${CPUN(4>kb&5$V^h>gdOiGchONXhhy>U_)+rhX<a74X~UXv%T
zX++p2A4N$i`-1U6E+cqs4SVy9^G>$ea;Telj!bjC{HbA6`bvJ9-p{V`(DNM(J?Aup
zk^DU&0FkTacL-9W>*dM7TSGS2T9LHNlW`@yr7m*Kts{&IA_#WEs>BerZkN@x;ub=)
zyY<`h_hy88un5&2GeSL@x^+@^SB7$->ynB}g$i}+T3T@+b?bt<ua#mArRdfvqsX`M
zh9lS&N62$QMy^|bH7SkV6H2ww73+dfRp4x}Y1tw)gD}F3NE`Z8@D=7CZO>8B4xM(e
zy>_kKV7fqy8JZp_H2r?^3Gv1>_j0GlrH||`79)=gNp}TFZT#>6N!C0}&eWDCt?H9h
zE*#kT>Ce8P0a4tA@d467YEW9Y&r0v3^rN4X8I<Ob@e3xk`^BVI90|*qVal3v@RI>)
z`XQj>rS1!_4}fJ1L8Ir+wpxlPHw+4CU?c0K$1CH}w@Wc5_uC?1<&jty$-K742aZ&3
z^pkbr5rDC4>!N%s<3i*MftS#cWptS%HQSeD_GQl;saADhUuZxNl{%TUwHcJKcFs{L
zMhR7%QDH`}-8$3U*1%Nnu(Iw;g41o50wEe6%9=MuFwe@LMK&*Q&%C&(bo#!A@!II(
z@%M%a?zN+SAV^&FRSsq-MN!e$`;ynd5t+J7UG>$;KHH_%-AX@_Hwjbg2)uk3!g6Z8
zeQN!i`^EIH)9LKpkAuYxzVi;FfW_$Qm%(^EfA`bp(c<dn-Osbp^>s0$WjO(#yf94C
z**WR9U^3T*?VL^3nhr{jm*1d_2s7JxA#^%MBZL+*1dn}=qMa}@jQB}Qc38j7inW3X
z#QJTPQb(^+`sIwGJkBUbx-WsWKD=>8Eh1eTPjzUO2irqLm^je2%=kx16z2k`Zii5k
z3W>wqPBz(Y?52`J=K_+GjdFjU6-5qRQ-`jOd84U=+T_S}ACaqz=WzM*1wz`ul}emV
z=|#A;zVDeaG?6n9tca8c%e8x~N~3Z|l`YiP(2#BgT`~ti!?b{$nSJB&sy)usY;+R^
z(0~j;9Z{(RR+6BXl0v|0m{%s!sI?1NJK1ErfYtbwysXOs>q!NysFFF^nm%GhWT}-4
z2s1~lyDWHi(XBII%(}*)ODA<GhB>c+thy5*`rw#yK1kL|+0;Z)b^ENOSXa_PSh_Vo
sL#}u}*x1oWl{`m>j^*p|;Gvj({jPk0|6R`pw_m^ee{*Vg2IZpx0BZ=6%m4rY

diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index e6f53922b..a75699626 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -393,11 +393,6 @@ drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
           nameOfItem = _itName $ _flIt flIt
           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
diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs
index 211436eb4..e1c1e4f20 100644
--- a/src/Dodge/Update.hs
+++ b/src/Dodge/Update.hs
@@ -4,7 +4,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.WallCreatureCollisions
 import Dodge.LevelGen.Block
-import Dodge.Camera
+import Dodge.Update.Camera
 import Dodge.SoundLogic
 import Dodge.Inventory
 
diff --git a/src/Dodge/Camera.hs b/src/Dodge/Update/Camera.hs
similarity index 92%
rename from src/Dodge/Camera.hs
rename to src/Dodge/Update/Camera.hs
index 033c056e1..dd265d3c0 100644
--- a/src/Dodge/Camera.hs
+++ b/src/Dodge/Update/Camera.hs
@@ -1,4 +1,4 @@
-module Dodge.Camera where
+module Dodge.Update.Camera where
 
 import Dodge.Data
 import Dodge.Base
@@ -45,9 +45,6 @@ moveCamera w = w & cameraPos .~ idealPos
           sightFrom | isCam     = camCenter
                     | otherwise = ypos
 
-
- 
-
 updateScopeZoom :: World -> World
 updateScopeZoom w 
     | SDL.ButtonRight `S.member` _mouseButtons w = case w ^? scppoint of
@@ -122,16 +119,13 @@ zoomCamOut w | SDL.KeycodeK `S.member` _keys w
                     = w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
              | otherwise = w
 
--- the 395 here limits the max zoom out, is 25 less than the current screen
--- size, thus matches up with it
 zoomCam :: World -> World
---zoomCam w = w
 zoomCam w = over cameraZoom changeZoom w
     where maxViewDistance = 800
           camPos = _cameraCenter w
           camRot = _cameraRot w
-          wallZoom = min (halfWidth w / (horizontalMax+10) ) 
-                                  (halfHeight w / (verticalMax+10) )
+          wallZoom = min (halfWidth w / (horizontalMax+50) ) 
+                                  (halfHeight w / (verticalMax+50) )
           idealZoom | SDL.ButtonRight `S.member` _mouseButtons w 
                         = scZoom * 
                             (
@@ -143,10 +137,13 @@ zoomCam w = over cameraZoom changeZoom w
                         = min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
                               $ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
                                     (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac))
-          changeZoom curZoom | curZoom > idealZoom + 0.01 = 0.05 * (19*curZoom + idealZoom)
-                             | curZoom < idealZoom - 0.01 = 0.05 * (19*curZoom + idealZoom)
-                             | otherwise                  = idealZoom
---          zs = take 20 [-maxViewDistance,0 - 0.9*maxViewDistance..]
+          changeZoom curZoom 
+            | curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed
+            | curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed
+            | otherwise                  = idealZoom
+        -- these speeds are inverted, larger means slower
+          zoomInSpeed  = 25
+          zoomOutSpeed = 15
           zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
           rRays = rotF [( maxViewDistance,y) | y <- zs]
           lRays = rotF [(-maxViewDistance,y) | y <- zs]

From 1ecbe2375d4c3ae00b811c423323091a7a0822f8 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 15:38:58 +0100
Subject: [PATCH 16/17] Refactor wall drawing

---
 src/Dodge/Rendering.hs     | 55 +++++++++++++++++++-------------------
 src/Dodge/Update/Camera.hs |  7 +++--
 src/Geometry.hs            | 10 +++++++
 3 files changed, 40 insertions(+), 32 deletions(-)

diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index a75699626..6d0fe3e7a 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -239,21 +239,14 @@ drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps,
         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'
         
-drawWallFloor :: Wall -> Drawing
-drawWallFloor (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c}) 
-        = onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps
-drawWallFloor wl = case _wlDraw wl of
-        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
-        Just d -> d wl
+drawWallFloor :: Wall -> Picture
+drawWallFloor wl = if _wlIsSeeThrough wl
+                   then onLayerL [levLayer WlLayer] $ color c $ polygon [x,x +.+ n2,y+.+n2, y]
+                   else blank
     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
+        n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
 
 errorNormalizeVDR :: Point2 -> Point2
 errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
@@ -304,31 +297,37 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
     where sp = screenPolygon w
           sps = zip sp (tail sp ++ [head sp])
 
-drawWallFace :: World -> Wall -> Drawing
+drawWallFace :: World -> Wall -> Picture
 drawWallFace w wall
     | isRHS sightFrom x y = blank
     | otherwise = colorAndLayer $ polygon $ points
     where 
         colorAndLayer | _wlIsSeeThrough wall = setLayer 2
                                                 . onLayerL [levLayer ShadowLayer,3] 
-                                                . color (withAlpha 0.2 $ _wlColor wall)
-                      | otherwise = setLayer 2 
-                                        . onLayerL [levLayer ShadowLayer,2]
+                                                . color (withAlpha 0.5 $ _wlColor wall)
+                      | otherwise = setLayer 0 
+                                        . onLayerL [levLayer ShadowLayer,l]
                                         . color (_wlColor wall)
         (x:y:_) = _wlLine wall 
-        ds = map (\p -> safeNormalizeV (p -.- sightFrom)) [x,y]
-        p's = zipWith (\d x -> (15 *.* d) +.+ x) ds [x,y]
+        points = extendConeToScreenEdge w sightFrom (x,y)
         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 ++ [x,y])
+        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:
+-- it is not obvious which will be returned
+intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
+intersectLinefromScreen w a b = listToMaybe 
+        . mapMaybe (\(x,y) -> intersectSegLineFrom' x y a b)
+        . makeLoopPairs 
+        $ screenPolygon w
+
+extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
+extendConeToScreenEdge w c (x,y) = orderPolygon $ [x,y] ++ borderPs ++ cornerPs
+    where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
+          cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
 
 displayInv :: Int -> World -> Picture
 displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) 
diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs
index dd265d3c0..66061796c 100644
--- a/src/Dodge/Update/Camera.hs
+++ b/src/Dodge/Update/Camera.hs
@@ -35,7 +35,6 @@ moveCamera w = w & cameraPos .~ idealPos
           idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
           currentOffset = currentPos -.- camCenter
           idealPos = camCenter +.+ rotateV (_cameraRot w) 
-                                           -- (aimRangeFactor * aimTimeFactor *.* _mousePos w)
                                             (aimRangeFactor * aimingMult *.* _mousePos w)
           currentPos = _cameraPos w
           camCenter  = ypos +.+ scope
@@ -96,7 +95,7 @@ zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just .
           Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
           currentCursorDisplacement = fromJust $ _itAttachment wp
 
-rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . zoomCam
+rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . autoZoomCam
 
 rotateCameraL :: World -> World
 rotateCameraL w | SDL.KeycodeQ `S.member` _keys w
@@ -119,8 +118,8 @@ zoomCamOut w | SDL.KeycodeK `S.member` _keys w
                     = w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
              | otherwise = w
 
-zoomCam :: World -> World
-zoomCam w = over cameraZoom changeZoom w
+autoZoomCam :: World -> World
+autoZoomCam w = over cameraZoom changeZoom w
     where maxViewDistance = 800
           camPos = _cameraCenter w
           camRot = _cameraRot w
diff --git a/src/Geometry.hs b/src/Geometry.hs
index e2e2d40af..e41cb800c 100644
--- a/src/Geometry.hs
+++ b/src/Geometry.hs
@@ -347,3 +347,13 @@ lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps
                         || any (isJust . uncurry (intersectSegSeg' a b)) pss
  where pss = zip ps (tail ps ++ [head ps])
 
+makeLoopPairs :: [Point2] -> [(Point2,Point2)]
+makeLoopPairs [] = error "tried to make loop with empty list of points"
+makeLoopPairs (x:[]) = error "tried to make loop with singleton list of points"
+makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
+
+-- note the pair is ordered
+-- doesn't work for obtuse angles
+pointIsInCone :: Point2 -> (Point2,Point2) -> Point2 -> Bool
+pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
+

From 279f928375630983ad975ebc6fbff1de79853973 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sun, 21 Mar 2021 17:10:10 +0100
Subject: [PATCH 17/17] Refactor shader creation

---
 src/Dodge/Rendering.hs    |  6 +++--
 src/Geometry/Intersect.hs | 15 +++++++++++
 src/Picture/Preload.hs    | 26 ++++++++++++------
 src/Shader.hs             | 55 +++++++++++----------------------------
 4 files changed, 52 insertions(+), 50 deletions(-)

diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs
index 6d0fe3e7a..0a4f19cb5 100644
--- a/src/Dodge/Rendering.hs
+++ b/src/Dodge/Rendering.hs
@@ -320,14 +320,16 @@ drawWallFace w wall
 -- it is not obvious which will be returned
 intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
 intersectLinefromScreen w a b = listToMaybe 
-        . mapMaybe (\(x,y) -> intersectSegLineFrom' x y a b)
+        . mapMaybe (\(x,y) -> intersectSegLineext x y a b)
         . makeLoopPairs 
         $ screenPolygon w
 
 extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
-extendConeToScreenEdge w c (x,y) = orderPolygon $ [x,y] ++ borderPs ++ cornerPs
+extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
     where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
           cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
+          wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' x y) 
+                                    . makeLoopPairs $ screenPolygon w
 
 displayInv :: Int -> World -> Picture
 displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) 
diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs
index adc5e44ce..44277a725 100644
--- a/src/Geometry/Intersect.hs
+++ b/src/Geometry/Intersect.hs
@@ -44,6 +44,21 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
         t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
         u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
 
+-- this is probably not correct...
+intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegLineext #-}
+intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+    | den == 0 = Nothing
+    | den > 0 && ( t' < 0 || u' < den || t' > den )
+        = Nothing
+    | den < 0 && ( t' > 0 || u' > - den || t' < den )
+        = Nothing
+    | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
+    where 
+        den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
+        t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
+        u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
+
 intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
 {-# INLINE intersectSegLine' #-}
 intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs
index 34bea19f4..78a371e41 100644
--- a/src/Picture/Preload.hs
+++ b/src/Picture/Preload.hs
@@ -21,6 +21,7 @@ data RenderData = RenderData
     { _lightSourceShader :: FullShader (Float,Float,Float,Float)
     , _wallShadowShader  :: FullShader (Point2,Point2)
     , _wallLightShader   :: FullShader (Point2,Point2)
+    , _wallFaceShader    :: FullShader (Point2,Point2,Point4)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
     , _listShaders :: [FullShader RenderType]
@@ -35,11 +36,11 @@ preloadRender = do
 -- lighting shaders
     lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points 
                     (return . return . flat4)
-    wsShad <- makeShaderCustomUnis "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
-                ["lightPos","perpMat","facesToDraw"]
+    wsShad <- makeShader "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+                >>= addUniforms ["lightPos","perpMat","facesToDraw"]
     wlLightShad 
-         <- makeShaderCustomUnis "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
-                    ["lightPos","perpMat","radLum"]
+         <- makeShader "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+                >>= addUniforms ["lightPos","perpMat","radLum"]
 
 -- 2D draw shaders
     bslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Triangles pokeTriStrat
@@ -48,9 +49,9 @@ preloadRender = do
     eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [(0,3),(1,4)]       Triangles pokeEllStrat
     bezierQuadShader <- makeShader 
                       "twoD/bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)]    TriangleStrip pokeBezQStrat
-    cslist <- makeTextureShader "twoD/character" [vert,geom,frag] 
+    cslist <- makeShader "twoD/character" [vert,geom,frag] 
                                 [(0,3),(1,4),(2,3)] Points pokeCharStrat
-                                "data/texture/charMap.png"
+                  >>= addTexture "data/texture/charMap.png"
 
 -- fullscreen shader
     fsShad <- makeShader "fullscreen" [vert,frag] [(0,2),(1,2)] TriangleStrip 
@@ -63,8 +64,13 @@ preloadRender = do
     n <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
 
 -- background shader
-    bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
-                                "data/texture/smudgedDirt.png"
+    bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
+                >>= addTexture "data/texture/smudgedDirt.png"
+
+-- wallShader
+    wlShad <- makeShader "wallFace" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
+                >>= addTexture "data/texture/smudgedDirt.png"
+                >>= addUniforms ["perpMat"]
 
 -- framebuffer for lighting
     (fbo,fboTO) <- setupFramebuffer
@@ -77,6 +83,7 @@ preloadRender = do
         , _lightSourceShader = lsShad
         , _wallShadowShader  = wsShad
         , _wallLightShader   = wlLightShad
+        , _wallFaceShader    = wlShad
         , _backgroundShader  = bgShad
         , _fullscreenShader  = fsShad
         , _spareFBO = fbo
@@ -148,6 +155,9 @@ frag = FragmentShader
 pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
 pokeWPStrat ((x,y),(z,w)) = [[[x,y,z,w]]]
 
+pokeWPColStrat :: (Point2,Point2,Point4) -> [[[Float]]]
+pokeWPColStrat ((x,y),(z,w),(r,g,b,a)) = [[[x,y,z,w],[r,g,b,a]]]
+
 pokeBGStrat :: a -> [[[Float]]]
 pokeBGStrat = const []
 
diff --git a/src/Shader.hs b/src/Shader.hs
index d46b2857b..6d3419ddc 100644
--- a/src/Shader.hs
+++ b/src/Shader.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Shader
     ( makeShader
-    , makeTextureShader
-    , makeShaderCustomUnis
+    , addTexture
+    , addUniforms
     , pokeShaders
     , pokeShader
     , bindArrayBuffers
@@ -28,6 +28,9 @@ import Codec.Picture
 import qualified Data.Vector.Storable as V
 
 import Control.Monad (when, forM, zipWithM_, forM_, foldM)
+import Control.Lens
+
+import Data.Maybe (fromMaybe)
 
 import qualified Control.Foldl as F
 
@@ -97,13 +100,10 @@ drawShader fs i = do
         _   -> return ()
     drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
 
-makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)] 
-            -> PrimitiveMode -> (a -> [[[Float]]]) 
-            -> String
-            -> IO (FullShader a)
-makeTextureShader s shaderlist alocs pm renStrat texturePath = do
-    (prog,unis)  <- makeSourcedShader s shaderlist
-
+-- I am not sure if this assumes that the shader is constructed directly before
+-- the texture is added...
+addTexture :: String -> FullShader a -> IO (FullShader a)
+addTexture texturePath shad = do
     Right cmap <- readImage texturePath
     let tex = convertRGBA8 cmap
     textureOb <- genObjectName
@@ -116,31 +116,7 @@ makeTextureShader s shaderlist alocs pm renStrat texturePath = do
                         (PixelData RGBA UnsignedByte ptr)
     generateMipmap' Texture2D
     textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
-
-    vao        <- setupVAO alocs
-
-    return $ FullShader { _shaderProgram = prog
-                        , _shaderUniforms = unis
-                        , _shaderVAO = vao
-                        , _shaderPokeStrategy = renStrat
-                        , _shaderDrawPrimitive = pm
-                        , _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb}
-                        , _shaderCustomUnis = Nothing
-                        }
-
-makeShaderCustomUnis :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) 
-                -> [String] -> IO (FullShader a)
-makeShaderCustomUnis s shaderlist alocs pm renStrat uniStrings = do
-    (prog,unis,unis')  <- makeSourcedShaderCustomUnis s shaderlist uniStrings
-    vao        <- setupVAO alocs
-    return $ FullShader { _shaderProgram = prog
-                        , _shaderUniforms = unis
-                        , _shaderVAO = vao
-                        , _shaderPokeStrategy = renStrat
-                        , _shaderDrawPrimitive = pm
-                        , _shaderTexture = Nothing
-                        , _shaderCustomUnis = Just unis'
-                        }
+    return $ shad & shaderTexture .~ Just (ShaderTexture {_textureObject = textureOb})
 
 makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
 makeShader s shaderlist alocs pm renStrat = do
@@ -203,12 +179,11 @@ makeSourcedShader s sts = do
                     $ \uniString -> uniformLocation prog uniString
     return (prog,uniformLocations)
 
-makeSourcedShaderCustomUnis :: String -> [ShaderType] -> [String] 
-                -> IO (Program, [UniformLocation], [UniformLocation])
-makeSourcedShaderCustomUnis s shadTypes uniStrings = do
-    (prog,unis0) <- makeSourcedShader s shadTypes
-    unis <- mapM (uniformLocation prog) uniStrings
-    return (prog,unis0,unis)
+addUniforms :: [String] -> FullShader a -> IO (FullShader a)
+addUniforms uniStrings shad = do
+    uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
+    return $ shad & shaderCustomUnis %~ Just . (++ uniLocs) . fromMaybe []
+
 
 shaderTypeExt :: ShaderType -> String
 shaderTypeExt VertexShader   = ".vert"