Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/dodge

shader/lighting/lightmapCircle.frag

@@ -0,0 +1,13 @@
+#version 430 core
+in vec2 cenPosT;
+in float lum;
+
+in vec2 dField;
+
+out vec4 fColor;
+
+void main()
+{
+  float c = pow (1 - min(1, dot(dField,dField)) , 2) * lum ;
+  fColor = vec4(c,c,c,c);
+}

shader/lighting/lightmapCircle.geom

@@ -2,27 +2,32 @@
 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 = vParams[0].x * zoom * 2;
-  float gRad = gParams.x;
 
   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);
+  dField = vec2 ( 1, 1);
+  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.9 , 1);
+  dField = vec2 (-1, 1);
+  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.9 , 1);
+  dField = vec2 ( 1,-1);
+  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.9 , 1);
+  dField = vec2 (-1,-1);
+  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
   EmitVertex();
 
   EndPrimitive();

shader/lighting/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);
+}

shader/lighting/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 shiftCloser (vec4 v)
+{ return vec4 (v.xy , v.z-0.0001 , 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 = 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; 
+    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();
+//}
+

shader/lighting/wallShadow.geom

@@ -5,23 +5,23 @@ layout (triangle_strip, max_vertices = 11) out;
 uniform vec2 lightPos;
 uniform mat4 perpMat;
 uniform mat4 worldMat;
+uniform float facesToDraw;
 
-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);
@@ -39,6 +39,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 +55,7 @@ vec4 a8 = perpMat * p8;
   gl_Position = a2; EmitVertex();
   gl_Position = a7; EmitVertex();
   gl_Position = a6; EmitVertex();
-//  gl_Position = a5; EmitVertex();
+
   EndPrimitive();
 } else {}
 }

shader/lighting/wallShadow.vert

@@ -0,0 +1,7 @@
+#version 430 core
+layout (location = 0) in vec4 poss;
+
+void main()
+{
+  gl_Position = poss;
+}

shader/lightmapCircle.frag

@@ -1,12 +0,0 @@
-#version 430 core
-in vec2 cenPosT;
-in vec2 gParams;
-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);
-  fColor = vec4(c,c,c,c);
-}

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 = 8 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
           speed = 3 * equipFactor

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
+    where unwalkableWalls = IM.filter (fromMaybe True . (^? doorPathable)) ws
-          notDoor (AutoDoor {}) = False
-          notDoor _         = True
 
 furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
 furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems 

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 

src/Dodge/Data.hs

@@ -547,15 +547,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
-        , _wlCastShadow :: Bool
-        }
     | Door 
         { _wlLine :: [Point2] , _wlID :: Int 
         , _doorMech :: World -> World
@@ -563,6 +554,7 @@ data Wall
         , _wlDraw :: Maybe (Wall -> Drawing)
         , _wlSeen :: Bool
         , _wlIsSeeThrough :: Bool
+        , _doorPathable :: Bool
         }
     | Block 
         { _wlLine :: [Point2]
@@ -574,17 +566,8 @@ data Wall
         , _blHP :: Int
         , _wlIsSeeThrough :: Bool
         , _blVisible :: Bool
-        , _blShadows :: [Int]
         , _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 

src/Dodge/Floor.hs

@@ -32,7 +32,7 @@ lev1 = do
             (
             [return $ return $ Right deadEndRoom
             ]
-            ++ [slowDoorRoom]
+            ++ [roomMiniIntro]
             ++ [return $ connectRoom corridor
                ,return $ connectRoom door]
             ++ firstWeapon

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,16 +125,18 @@ autoGun = defaultGun
     , _itInvDisplay = displayAutoGun
     }
 autoFireMode = shootWithSound (fromIntegral autoGunSound) 
-                   $ withRecoil 40
+                   . withRecoil 40
-                   $ torqueBefore 0.05
+                   . torqueBefore 0.05
-                   $ withRandomDir (autogunSpread/2)
+                   . withRandomDir (autogunSpread/2)
-                   $ withVelWthHiteff (50,0) 3 
+                   . withMuzFlare
+                   . withVelWthHiteff (50,0) 3 
                    $ threeEff' bulHitCr' bulHitWall' bulHitFF'
 singleFireMode = shootWithSound (fromIntegral autoGunSound) 
-                   $ withRecoil 40
+                   . withRecoil 40
-                   $ torqueAfter 0.03
+                   . torqueAfter 0.03
-                   $ withRandomDir (autogunSpread/2)
+                   . withRandomDir (autogunSpread/2)
-                   $ withVelWthHiteff (50,0) 3 
+                   . withMuzFlare
+                   . withVelWthHiteff (50,0) 3 
                    $ threeEff' bulHitCr' bulHitWall' bulHitFF'
 
 incMode :: Int -> World -> World
@@ -422,8 +425,9 @@ hvAutoGun = defaultAutoGun
     , _itEquipPict = drawWeapon $ color orange $ polygon $ rectNESW 5 5 (-5) (-5)
     }
         where mkHvBul = withSound (fromIntegral longGunSound)
-                            $ withThinSmoke
+                            . withThinSmoke
-                            $ withVelWthHiteff (80,0) 6 
+                            . withMuzFlare
+                            . withVelWthHiteff (80,0) 6 
                             $ threeEff' 
                                         hvBulHitCr' hvBulHitWall' bulHitFF'
                             
@@ -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
+                . withThickSmoke
-                $ torqueAfter 0.05
+                . torqueAfter 0.05
-                $ withVelWthHiteff (60,0) 6 
+                . withMuzFlare
-                                    $ threeEff'
+                . withVelWthHiteff (60,0) 6 
-                                        hvBulHitCr' hvBulHitWall' bulHitFF'
+                $ threeEff' hvBulHitCr' hvBulHitWall' bulHitFF'
 
     , _wpSpread = 0.0
     , _wpRange = 200

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))
+--        . over tempLightSources ((:) (tLightAt 4 pos))
-        . lowLightAt pos2
+--        . lowLightAt pos2
         $ set randGen g
         w
     where cr = _creatures w IM.! cid

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

src/Dodge/LevelGen/AutoDoor.hs

@@ -24,15 +24,8 @@ 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
-                               ]
                                [ [pld,hwd,hw,pl]
                                , [hwd,hwu]
                                , [hwu,plu,pl,hw]
@@ -68,24 +61,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
+autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
-drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] 
+autoDoorPane trigL n closedPos openPos = Door
-        $ 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
     { _wlLine = closedPos
     , _wlID = n
     , _doorMech = dm
@@ -93,7 +70,7 @@ autoDoorPane trigL n castShad closedPos openPos = AutoDoor
     , _wlDraw = Nothing
     , _wlSeen = False
     , _wlIsSeeThrough = False
-    , _wlCastShadow = castShad
+    , _doorPathable = True
     }
     where 
         a = closedPos !! 0

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 

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

src/Dodge/Prototypes.hs

@@ -29,14 +29,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
-                   , _wlCastShadow = True
+                   , _doorPathable = True
                    }
 basicDoor = Door { _wlLine = [(0,0),(50,0)]
                    , _wlID = 0
@@ -45,6 +45,7 @@ basicDoor = Door { _wlLine = [(0,0),(50,0)]
                    , _wlDraw = Nothing
                    , _wlSeen = False
                    , _wlIsSeeThrough = False
+                   , _doorPathable = False
                    }
 basicCreature :: Creature
 basicCreature = Creature

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 
@@ -70,9 +67,8 @@ worldPictures w
                         , ptPicts'
                         , afterPtPicts'
                         , wlPicts'
---                        , wallShadows
+                        , wlPicts
                         , smokeShadows
---                        , itLabels
                         , ppLabels
                         , btLabels
                         , testPic w
@@ -86,11 +82,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 drawWallFloor (wallFloorsToDraw w)
-          wlPicts'      = map (drawWall' w) (wallsToDraw w)
+          wlPicts'      = map (drawWallFace w) (wallShadowsToDraw w)
-          itFloorPicts  = map (drawItem) (IM.elems (_floorItems w))
+          itFloorPicts  = map drawItem (IM.elems (_floorItems w))
           yourPos = _crPos $ you w
           yourRot = _crDir $ you w
           yourRad = _crRad $ you w
@@ -122,8 +117,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]
+testPic w = [blank]
-     [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ]
+    -- [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ]
     -- $ uncurry translate (mouseWorldPos w) 
 
 
@@ -198,8 +193,8 @@ mapWall wl =
           (x:y:_) = _wlLine wl
           c = _wlColor wl
 
-wallsToDraw :: World -> [Wall]
+wallFloorsToDraw :: World -> [Wall]
-wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
+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
@@ -244,23 +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'
         
-drawWall :: Wall -> Drawing
+drawWallFloor :: Wall -> Picture
-drawWall (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c}) 
+drawWallFloor wl = if _wlIsSeeThrough wl
-        = onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps
+                   then onLayerL [levLayer WlLayer] $ color c $ polygon [x,x +.+ n2,y+.+n2, y]
-drawWall wl = case _wlDraw wl of
+                   else blank
---        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon $ _wlLine wl
-        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
-        Just d -> d wl
     where 
         (x:y:_) = _wlLine wl
         c = _wlColor wl
-        t = 5 *.* errorNormalizeVDR (y -.- x)
+        n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
-        n = vNormal t
-        n2 = 3 *.* n
-        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"
@@ -311,67 +297,39 @@ 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
+drawWallFace :: World -> Wall -> Picture
-drawWall' w wall
+drawWallFace w wall
     | isRHS sightFrom x y = blank
     | otherwise = colorAndLayer $ polygon $ points
     where 
         colorAndLayer | _wlIsSeeThrough wall = setLayer 2
-                                                . onLayerL [levLayer ShadowLayer] 
+                                                . onLayerL [levLayer ShadowLayer,3] 
-                                                . color (withAlpha 0.2 $ _wlColor wall)
+                                                . color (withAlpha 0.5 $ _wlColor wall)
-                      | otherwise = setLayer 2 
+                      | otherwise = setLayer 0 
-                                        . onLayerL [levLayer ShadowLayer,2]
+                                        . onLayerL [levLayer ShadowLayer,l]
                                         . color (_wlColor wall)
         (x:y:_) = _wlLine wall 
-        ps = linePointsBetween x y
+        points = extendConeToScreenEdge w sightFrom (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
+        l = case wall of
-        borders = filter g $ zip corns (tail corns ++ [head corns])
+                Door {} -> 1
-        g (a,b) = isLHS a b sightFrom
+                _ -> 2
-        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 ++ ps)
-        --points = orderPolygon (borderps ++ p's)
 
-drawWallShadow :: World -> Wall -> Drawing
+-- the following assumes that the point a is inside the screen
-drawWallShadow w wall
+-- it still works otherwise, but it might intersect two points:
-    | isRHS sightFrom x y = blank
+-- it is not obvious which will be returned
-    | otherwise = colorAndLayer $ polygon $ points
+intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
-    where 
+intersectLinefromScreen w a b = listToMaybe 
-        colorAndLayer | _wlIsSeeThrough wall = setLayer 2
+        . mapMaybe (\(x,y) -> intersectSegLineext x y a b)
-                                                . onLayerL [levLayer ShadowLayer] 
+        . makeLoopPairs 
-                                                . color (withAlpha 0.2 $ _wlColor wall)
+        $ screenPolygon w
-                      | 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]
+extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
-linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n-1] ++ [p']
+extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
-                       | otherwise = [p,p']
+    where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
-    where d = dist p p'
+          cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
-          n = ceiling $ d / 50
+          wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' x y) 
-          p'' = (1/fromIntegral n) *.* (p' -.- p)
+                                    . makeLoopPairs $ screenPolygon w
 
 displayInv :: Int -> World -> Picture
 displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) 
@@ -397,10 +355,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)]
                                     ]
@@ -429,10 +383,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)]
                                     ]
@@ -444,11 +394,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
@@ -496,22 +441,10 @@ 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)
-    where getLS ls  = ( fst $ ssls ls, snd $ ssls ls,  _lsRad ls , _lsIntensity ls)
+    where getLS ls  = ( fst $ _lsPos ls, snd $ _lsPos ls,  _lsRad ls , _lsIntensity ls)
-          getTLS ls = ( fst $ sstls ls,snd $ sstls ls, _tlsRad ls, _tlsIntensity ls)
+          getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos 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

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
 
@@ -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))
 

src/Dodge/Update/Camera.hs

@@ -1,4 +1,4 @@
-module Dodge.Camera where
+module Dodge.Update.Camera where
 
 import Dodge.Data
 import Dodge.Base
@@ -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
@@ -45,9 +44,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
@@ -99,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
@@ -122,16 +118,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
+autoZoomCam :: World -> World
--- size, thus matches up with it
+autoZoomCam w = over cameraZoom changeZoom w
-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) ) 
+          wallZoom = min (halfWidth w / (horizontalMax+50) ) 
-                                  (halfHeight w / (verticalMax+10) )
+                                  (halfHeight w / (verticalMax+50) )
           idealZoom | SDL.ButtonRight `S.member` _mouseButtons w 
                         = scZoom * 
                             (
@@ -143,10 +136,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)
+          changeZoom curZoom 
-                             | curZoom < idealZoom - 0.01 = 0.05 * (19*curZoom + idealZoom)
+            | curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed
+            | curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed
             | otherwise                  = idealZoom
---          zs = take 20 [-maxViewDistance,0 - 0.9*maxViewDistance..]
+        -- 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]

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
 
@@ -343,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
+

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)

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
 

src/Picture/Preload.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
---{-# LANGUAGE Strict #-}
 module Picture.Preload
     ( RenderData (..)
     , preloadRender
@@ -8,28 +7,24 @@ 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
 
 data RenderData = RenderData
     { _lightSourceShader :: FullShader (Float,Float,Float,Float)
     , _wallShadowShader  :: FullShader (Point2,Point2)
-    , _wallLightShader  :: FullShader (Point3)
+    , _wallLightShader   :: FullShader (Point2,Point2)
+    , _wallFaceShader    :: FullShader (Point2,Point2,Point4)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
-    , _wallShader :: FullShader (Point3,Point4)
     , _listShaders :: [FullShader RenderType]
-    , _dummyVBO :: BufferObject
-    , _dummyPtr :: Ptr Float
     , _spareFBO :: FramebufferObject
     , _fboTexture :: TextureObject
     }
@@ -38,32 +33,27 @@ makeLenses ''RenderData
 
 preloadRender :: IO RenderData
 preloadRender = do
--- compile shader programs
+-- lighting shaders
-    lsShad <- makeShader "lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
+    lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points 
---    fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
+                    (return . return . flat4)
+    wsShad <- makeShader "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+                >>= addUniforms ["lightPos","perpMat","facesToDraw"]
+    wlLightShad 
+         <- makeShader "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+                >>= addUniforms ["lightPos","perpMat","radLum"]
 
-    bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
+-- 2D draw shaders
-                                "data/texture/smudgedDirt.png"
+    bslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Triangles pokeTriStrat
-
+    lslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Lines     pokeLineStrat
-    wsShad <- makeShaderCustomUnis "wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+    aslist <- makeShader "twoD/arc"     [vert,geom,frag] [(0,3),(1,4),(2,4)] Points    pokeArcStrat
-                ["lightPos","perpMat"]
+    eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [(0,3),(1,4)]       Triangles pokeEllStrat
-
+    bezierQuadShader <- makeShader 
-    wlLightShad <- makeShaderCustomUnis "wallLight" [vert,frag] [(0,3)] TriangleStrip pokeLightWallStrat
+                      "twoD/bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)]    TriangleStrip pokeBezQStrat
-                    ["lightPosRadLum"]
+    cslist <- makeShader "twoD/character" [vert,geom,frag] 
-
-    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] 
                                 [(0,3),(1,4),(2,3)] Points pokeCharStrat
-                                "data/texture/charMap.png"
+                  >>= addTexture "data/texture/charMap.png"
-
-    bezierQuadShader
-           <- makeShader "bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)]    TriangleStrip pokeBezQStrat
 
+-- fullscreen shader
     fsShad <- makeShader "fullscreen" [vert,frag] [(0,2),(1,2)] TriangleStrip 
                                 (const [[[-1, 1],[0,1]]
                                        ,[[ 1, 1],[1,1]]
@@ -71,32 +61,29 @@ preloadRender = do
                                        ,[[ 1,-1],[1,0]]
                                        ]
                                  )
-    n <- F.foldM (pokeShader fsShad) [()]
+    n <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
-    putStrLn $ show n
 
---the following vbo is set up to contain one fixed vertex
+-- background shader
-    dummyvbo <- genObjectName
+    bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
-    dummyptr <- mallocArray numDrawableElements
+                >>= addTexture "data/texture/smudgedDirt.png"
-    pokeArray dummyptr [0..2000]
-    bindBuffer ArrayBuffer $= Just dummyvbo
-    bufferData ArrayBuffer $= (fromIntegral floatSize, dummyptr, StaticDraw)
 
--- input a list of (attribute location, attrib length) pairs
+-- wallShader
--- these will have buffers and pointers created
+    wlShad <- makeShader "wallFace" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
-    backgroundvao <- setupVAO [(0,4),(1,2)]
+                >>= addTexture "data/texture/smudgedDirt.png"
+                >>= addUniforms ["perpMat"]
 
+-- framebuffer for lighting
     (fbo,fboTO) <- setupFramebuffer
 
+-- reset to default framebuffer, ready for drawing direct to screen
     bindFramebuffer Framebuffer $= defaultFramebufferObject
     
     return $ RenderData
         { _listShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
-        , _dummyVBO = dummyvbo
-        , _dummyPtr = dummyptr
         , _lightSourceShader = lsShad
         , _wallShadowShader  = wsShad
         , _wallLightShader   = wlLightShad
-        , _wallShader        = wlShad
+        , _wallFaceShader    = wlShad
         , _backgroundShader  = bgShad
         , _fullscreenShader  = fsShad
         , _spareFBO = fbo
@@ -135,7 +122,7 @@ cleanUpRenderPreload pd = do
     freeShaderPointers $ _lightSourceShader pd
     freeShaderPointers $ _wallShadowShader pd
     freeShaderPointers $ _backgroundShader pd
-    free $ _dummyPtr pd
+    freeShaderPointers $ _fullscreenShader pd
 
 {-# INLINE pokeBezQStrat #-}
 pokeBezQStrat :: RenderType -> [[[Float]]]
@@ -149,9 +136,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 _ = []
 
@@ -164,9 +148,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
@@ -174,8 +155,8 @@ frag = FragmentShader
 pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
 pokeWPStrat ((x,y),(z,w)) = [[[x,y,z,w]]]
 
-pokeLightWallStrat :: Point3 -> [[[Float]]]
+pokeWPColStrat :: (Point2,Point2,Point4) -> [[[Float]]]
-pokeLightWallStrat (x,y,z) = [[[x,y,z]]]
+pokeWPColStrat ((x,y),(z,w),(r,g,b,a)) = [[[x,y,z,w],[r,g,b,a]]]
 
 pokeBGStrat :: a -> [[[Float]]]
 pokeBGStrat = const []

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)
         )
@@ -61,30 +60,41 @@ 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)
 
     currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
     uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
-            $= Vector2 viewFromx viewFromy  -- hopefully this draws as if from the center
+            $= Vector2 viewFromx viewFromy  
-                                     -- it does, but this is not correct when
-                                     -- the camera center is not the player position
-    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)
+            $= (0 :: Float)
     cullFace $= Just Back
+    cullFace $= Nothing
     drawShader (_wallShadowShader pdata) nWalls
 
+
     depthMask $= Disabled
     blendFunc $= (Zero, OneMinusSrcAlpha)
 --    blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
     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 +113,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)
@@ -112,12 +123,12 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
         stencilFunc $= (Equal, 0, 255)
         drawShader (_lightSourceShader pdata) 1
 
---        currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
+        currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
---        uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
+        uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
---            $= Vector4 x y r lum
+                $= Vector2 x y  
---        cullFace $= Just Front
+        uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 2)
---        depthFunc $= Just Lequal
+                $= Vector2 r lum
---        drawShader (_wallLightShader pdata) nLightWalls
+        drawShader (_wallLightShader pdata) nWallLights
         
     depthMask $= Enabled
     cullFace $= Nothing
@@ -173,42 +184,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

src/Shader.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Shader
     ( makeShader
-    , makeTextureShader
+    , addTexture
-    , makeShaderCustomUnis
+    , 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)] 
+-- I am not sure if this assumes that the shader is constructed directly before
-            -> PrimitiveMode -> (a -> [[[Float]]]) 
+-- the texture is added...
-            -> String
+addTexture :: String -> FullShader a -> IO (FullShader a)
-            -> IO (FullShader a)
+addTexture texturePath shad = do
-makeTextureShader s shaderlist alocs pm renStrat texturePath = do
-    (prog,unis)  <- makeSourcedShader s shaderlist
-
     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)
-
+    return $ shad & shaderTexture .~ Just (ShaderTexture {_textureObject = textureOb})
-    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'
-                        }
 
 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] 
+addUniforms :: [String] -> FullShader a -> IO (FullShader a)
-                -> IO (Program, [UniformLocation], [UniformLocation])
+addUniforms uniStrings shad = do
-makeSourcedShaderCustomUnis s shadTypes uniStrings = do
+    uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
-    (prog,unis0) <- makeSourcedShader s shadTypes
+    return $ shad & shaderCustomUnis %~ Just . (++ uniLocs) . fromMaybe []
-    unis <- mapM (uniformLocation prog) uniStrings
+
-    return (prog,unis0,unis)
 
 shaderTypeExt :: ShaderType -> String
 shaderTypeExt VertexShader   = ".vert"