Add test tileset textures

src/Dodge/Creature/Action/UseItem.hs

@@ -16,7 +16,7 @@ useItem n w = itemEffect c it w
 -- TODO this needs sorting out and possibly removing
 crUseItem :: Creature -> World -> World
 --crUseItem cr = itemEffect (_crID cr) (_crInv cr IM.! _crInvSel cr)
-crUseItem cr = tryUseItem cr
+crUseItem = tryUseItem
 
 tryUseItem 
     :: Creature      

src/Dodge/Creature/Picture.hs

@@ -68,7 +68,7 @@ feet cr = case cr ^? crStance . carriage of
         , translate 0 (-off) $ circleSolid 5
         ]
   where
-    setL = onLayerL [levLayer CrLayer, (-5)] . color (greyN 0.3) . pictures
+    setL = onLayerL [levLayer CrLayer, -5] . color (greyN 0.3) . pictures
     off = 5
     sLen = _strideLength $ _crStance cr
     f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
@@ -86,7 +86,7 @@ arms col cr
         _ -> blank 
   where
     sc = scale 1 1
-    setL = onLayerL [levLayer CrLayer, (-4)] . color (light4 col) . pictures
+    setL = onLayerL [levLayer CrLayer, -4] . color (light4 col) . pictures
     off = 8
     sLen = _strideLength $ _crStance cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
@@ -103,20 +103,20 @@ naked col cr
         [ translate (0.25 * crad) 0 $ circleSolid (crad * 0.5)
         , onCrL . translate 8 (-8) . color col' $ circleSolid 4
         , translate 0 3 . rotate (negate 0.2) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
-        , translate 0 (negate 3) . rotate (0.2) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
+        , translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
         ]
     | aimingTwist = translate 0 (0.5* crad) . rotate twistA $ pictures 
         [ aboveIt . translate (negate 0.25 * crad) 0.25 $ 
             circleSolid (crad * 0.5)
-        , onCrL . translate 12 (4) . color col' $ circleSolid 4
+        , onCrL . translate 12 4 . color col' $ circleSolid 4
         , onCrL . translate 4 (-10) . color col' $ circleSolid 4
         , onCrL . rotate (negate 0.2) . translate 2 3 . rotate (negate 0.4) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
-        , onCrL . rotate (negate 0.2) . translate 0 (negate 3) . rotate (0.2) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
+        , onCrL . rotate (negate 0.2) . translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
         ]
     | otherwise     = onCrL $ pictures 
         [ translate (0.25 * crad) 0 $ circleSolid (crad * 0.5)
         , translate 0 3 . rotate (negate 0.2) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
-        , translate 0 (negate 3) . rotate (0.2) . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
+        , translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
         ]
   where
     aboveIt = onLayer HPtLayer

src/Dodge/Default.hs

@@ -162,9 +162,9 @@ defaultPT = Projectile
     { _pjPos = (0,0)
     , _pjStartPos = (0,0)
     , _pjVel = (0,0)
-    , _pjDraw = \_ -> blank
+    , _pjDraw = const blank
     , _pjID = 0
-    , _pjUpdate = \_ -> id
+    , _pjUpdate = const id
     }
 defaultPP :: PressPlate
 defaultPP = PressPlate

src/Dodge/Default/Shell.hs

@@ -11,9 +11,9 @@ defaultShell = Shell
     , _pjAcc = (0,0)
     , _pjDir = 0
     , _pjSpin = 0
-    , _pjDraw = \_ -> blank
+    , _pjDraw = const blank
     , _pjID = 0
     , _pjTimer = 0
-    , _pjUpdate = \_ -> id
+    , _pjUpdate = const id
-    , _pjPayload = \_ -> id
+    , _pjPayload = const id
     }

src/Dodge/Default/Weapon.hs

@@ -46,9 +46,9 @@ defaultAutoGun = defaultGun
     }
 defaultShellAmmo :: Ammo
 defaultShellAmmo = ShellAmmo
-    { _amPayload = \_ -> id
+    { _amPayload = const id
     , _amString = "Shell"
     , _amPjParams = []
-    , _amPjDraw = \_ -> blank
+    , _amPjDraw = const blank
     , _amParamSel = 0
     }

src/Dodge/Event.hs

@@ -114,7 +114,7 @@ wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
 moveYourAmmoSel :: Int -> World -> World
 moveYourAmmoSel i w = case yourItem w ^? wpAmmo . amPjParams of
     Just l -> w & creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
-                    . wpAmmo . amParamSel %~ (`mod` (length l)) . (subtract i)
+                    . wpAmmo . amParamSel %~ (`mod` (length l)) . subtract i
     _ -> w
 moveYourAmmoParam :: Int -> World -> World
 moveYourAmmoParam i w = case yourItem w ^? wpAmmo . amPjParams . ix paramid . pjMaxParam of

src/Dodge/Item/Weapon.hs

@@ -92,12 +92,12 @@ useAmmoParams it = withVelWthHiteff (_amBulVel b) (_amBulWth b) (_amBulEff b)
 effectGun :: String -> (Creature -> World -> World) -> Item
 effectGun name eff = defaultGun
     { _itName = name ++ "Gun"
-    , _itUse = \_ -> eff
+    , _itUse = const eff
     }
 autoEffectGun :: String -> (Creature -> World -> World) -> Item
 autoEffectGun name eff = defaultAutoGun
     { _itName = name ++ "Gun"
-    , _itUse = \_ -> eff
+    , _itUse = const eff
     }
 rezGun :: Item
 rezGun = defaultGun
@@ -876,7 +876,7 @@ throwRemoteBomb cr w = setLocation
 explodeRemoteBomb :: Int -> Int -> Creature -> World -> World
 explodeRemoteBomb itid pjid cr w
     = set (projectiles . ix pjid . pjUpdate) (\_ -> retireRemoteBomb itid 30 pjid)
-        $ set (projectiles . ix pjid . pjDraw) (\_ -> blank)
+--        $ set (projectiles . ix pjid . pjDraw) (\_ -> blank)
         $ set (creatures . ix cid . crInv . ix j . itUse) (\_ -> const id)
         $ resetName
         $ resetPict

src/Dodge/Item/Weapon/Booster.hs

@@ -46,7 +46,7 @@ boostSelfL x cr invid w = case boostPoint x cr w of
             . (crInv . ix invid %~ 
                 ammoEff
                 . (itEffect . itEffectCounter .~ 1)
-                . (itAttachment .~ Just (ItInt pid))
+                . (itAttachment ?~ ItInt pid)
                 )
 
 boostSelf
@@ -85,8 +85,8 @@ updateLinearShockwave pj w
 drawBoostShockwave :: Projectile -> Picture
 drawBoostShockwave pj = setLayer 1 $ onLayer UPtLayer $ pictures $
     theArc ++
-    [ lineCol $ zip (reverse lps) $ map (flip withAlpha white) [0,0.05..]
+    [ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
-    , lineCol $ zip (reverse rps) $ map (flip withAlpha white) [0,0.05..]
+    , lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]
     ]
   where
 -- drawing half a circle here is not perfect, a slightly smaller arc would fit

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -56,7 +56,7 @@ itemLaserScopeEffect :: ItEffect
 itemLaserScopeEffect 
     = ItInvEffect {_itInvEffect = f ,_itEffectCounter = 0 }
   where 
-    moveHammerUp !HammerDown = HammerReleased
+    moveHammerUp HammerDown = HammerReleased
     moveHammerUp !_          = HammerUp
     f _ cr invid w 
         | invid == _crInvSel cr && crIsAiming' cr = w 

src/Dodge/Item/Weapon/Launcher.hs

@@ -35,7 +35,7 @@ launcher = defaultGun
     , _wpReloadState = 0
     , _itUseRate = 20
     , _itUseTime = 0
-    , _itUse = \it -> shootWithSound (fromIntegral launcherSound) $ aRocketWithItemParams it
+    , _itUse = shootWithSound (fromIntegral launcherSound) . aRocketWithItemParams
     , _wpSpread = 0.02
     , _wpRange = 20
     , _itFloorPict = onLayer FlItLayer launcherPic
@@ -64,7 +64,7 @@ basicAmPjMoves =
     ]
 spinDrag :: PjParam
 spinDrag = PjParam
-    { _pjMoveParam = \i _ _ -> reduceSpinBy (1 - (fromIntegral i)*2 / 200)
+    { _pjMoveParam = \i _ _ -> reduceSpinBy (1 - fromIntegral i*2 / 200)
     , _pjIntParam  = 1
     , _pjDisplayParam = pjPadText "SPIN SLOWDOWN" . show
     , _pjMaxParam = 5
@@ -87,7 +87,7 @@ thrustParam = PjParam
     }
 
 pjThrust :: Int -> Projectile -> World -> World
-pjThrust i = pjEffTimeRange (st,et) $ doThrust
+pjThrust i = pjEffTimeRange (st,et) doThrust
   where
     et | i == 0 = 36
        | otherwise = 40 - (fromIntegral i * 20)
@@ -131,7 +131,7 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
     i = IM.newKey $ _projectiles w
     pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
     dir = _crDir cr
-    ammoMvs pj w' = foldr (\pjP -> (_pjMoveParam pjP) (_pjIntParam pjP) it cr pj) w' (_amPjParams am)
+    ammoMvs pj w' = foldr (\pjP -> _pjMoveParam pjP (_pjIntParam pjP) it cr pj) w' (_amPjParams am)
     theShell = defaultShell
         { _pjPos = pos
         , _pjStartPos = pos

src/Dodge/Item/Weapon/UseEffect.hs

@@ -126,7 +126,7 @@ tractorBeamAt colID i pos dir = Projectile
     { _pjPos = pos
     , _pjStartPos = p'
     , _pjVel = d
-    , _pjDraw = \_ -> blank
+    , _pjDraw = const blank
     , _pjID = i
     , _pjUpdate = \_ -> updateTractor colID 10 i
     }
@@ -139,7 +139,7 @@ The interaction of this with objects, walls etc needs more thought.  -}
 updateTractor :: Int -> Int -> Int -> World -> World
 updateTractor colID time i w
     | time > 0 = set (projectiles . ix i . pjUpdate) (\_ -> updateTractor colID (time-1) i) 
-                    $ set (projectiles . ix i . pjDraw) (\_ -> pic)
+                    $ set (projectiles . ix i . pjDraw) (const pic)
                     $ over creatures (IM.map tractCr) 
                     $ over floorItems (IM.map tractFlIt) 
                         w

src/Dodge/Render.hs

@@ -54,7 +54,7 @@ doDrawing pdata w = do
         pic = worldPictures w
         wallPoints = map fst wallPointsCol
     -- set the coordinate uniforms ready for drawing elements using world coordinates
-    setCommonUniforms pdata rot camzoom trans wins
+    setIsoMatrixUniforms pdata rot camzoom trans wins
     depthFunc $= Just Less
     pmat <- (newMatrix RowMajor $ perspectiveMatrix rot camzoom trans wins viewFroms) 
         :: IO (GLmatrix GLfloat)
@@ -138,8 +138,7 @@ renderBlankWalls pdata wps pmat = do
     n <- F.foldM (pokeShader $ _wallBlankShader pdata) wps
     bindShaderBuffers [_wallBlankShader pdata] [n]
     currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
-    uniform (( _shaderMatrixUniform $ _wallBlankShader pdata) )
+    uniform (_shaderMatrixUniform $ _wallBlankShader pdata) $= pmat
-        $= pmat
     cullFace $= Just Back
     drawShader (_wallBlankShader pdata) n
     cullFace $= Nothing
@@ -153,8 +152,7 @@ renderTextureWalls pdata wps pmat = do
     n <- F.foldM (pokeShader $ _wallTextureShader pdata) wps
     bindShaderBuffers [_wallTextureShader pdata] [n]
     currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata)
-    uniform (( _shaderMatrixUniform $ _wallTextureShader pdata) )
+    uniform (_shaderMatrixUniform $ _wallTextureShader pdata) $= pmat
-        $= pmat
     cullFace $= Just Back
     drawShader (_wallTextureShader pdata) n
     cullFace $= Nothing

src/Dodge/Render/Picture.hs

@@ -55,7 +55,7 @@ testPic w =
     ]
 
 crDraw :: World -> Creature -> Picture
-crDraw w c = (_crPict c c w)
+crDraw w c = _crPict c c w
 ppDraw :: PressPlate -> Picture
 ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
 btDraw :: Button -> Picture

src/Picture/Preload.hs

@@ -22,6 +22,7 @@ data RenderData = RenderData
     , _wallBlankShader          :: FullShader ((Point2,Point2),Point4)
     , _wallTextureShader        :: FullShader ((Point2,Point2),Point4)
     , _backgroundShader         :: FullShader (Point2,Point2,Point2,Point2)
+    , _textureShader            :: FullShader (Point3,Point2)
     , _fullscreenShader         :: FullShader ()
     , _boxBlurShader            :: FullShader ()
     , _grayscaleShader          :: FullShader ()
@@ -85,6 +86,11 @@ preloadRender = do
 -- textured wallShader
     wlTexture <- makeShader "wall/texture" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
                 >>= addTexture "data/texture/grayscaleDirt.png"
+
+-- texture shader
+    textShad <- makeShader "texture/simpleWorld" [vert,frag] [(0,3),(1,2)] Triangles poke32
+        >>= addTexture "data/texture/ayene_wooden_floor.png"
+
 -- framebuffer for lighting
     (fbo,fboTO,fboRBO) <- setupFramebufferWithStencil
     framebuf2 <- setupFramebufferWithStencil
@@ -98,6 +104,7 @@ preloadRender = do
         , _lightingWallShader       = wlLightShad
         , _wallBlankShader          = wlBlank
         , _wallTextureShader        = wlTexture
+        , _textureShader            = textShad
         , _backgroundShader         = bgShad
         , _fullscreenShader         = fsShad
         , _boxBlurShader            = boxBlurShad
@@ -209,5 +216,8 @@ 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]]]
 
+poke32 :: (Point3,Point2) -> [[[Float]]]
+poke32 ((x,y,z),(a,b)) = [[[x,y,z],[a,b]]]
+
 pokeBGStrat :: a -> [[[Float]]]
 pokeBGStrat = const []

src/Picture/Render.hs

@@ -31,7 +31,7 @@ setWallDepth
     -> (Float,Float)        -- ^ View from point
     -> GLmatrix GLfloat
     -> IO Word32
-setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do
+setWallDepth pdata wallPoints (viewFromx,viewFromy) _ = do
     startTicks <- SDL.ticks
     colorMask $= Color4 Disabled Disabled Disabled Disabled
     nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) wallPoints
@@ -41,6 +41,8 @@ setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do
     -- reseting this uniform appears to be necessary
     uniform (head $  _shaderCustomUnis $ _lightingOccludeShader pdata)
             $= Vector2 viewFromx viewFromy  
+    -- the following uniform, however, was probably already set by
+    -- createLightMap
 --    uniform ( (_shaderMatrixUniform $ _lightingOccludeShader pdata))
 --            $= pmat
 --    cullFace $= Just Front
@@ -92,8 +94,7 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _
     currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
     uniform (head $  _shaderCustomUnis $ _lightingOccludeShader pdata)
             $= Vector2 viewFromx viewFromy  
-    uniform ( (_shaderMatrixUniform $ _lightingOccludeShader pdata))
+    uniform (_shaderMatrixUniform $ _lightingOccludeShader pdata) $= pmat
-            $= pmat
     cullFace $= Just Back
     drawShader (_lightingOccludeShader pdata) nWalls
 
@@ -225,6 +226,34 @@ setCommonUniforms pdata rot camZoom (tranx,trany) (winx,winy) = do
         : map extractProgAndUnis (_pictureShaders pdata)
         )
 
+setIsoMatrixUniforms 
+    :: RenderData
+    -> Float            -- ^ Rotation
+    -> Float            -- ^ Zoom
+    -> (Float,Float)    -- ^ Translation
+    -> (Float,Float)    -- ^ Window size
+    -> IO ()
+setIsoMatrixUniforms pdata rot camZoom (tranx,trany) (winx,winy) = do
+    setShaderUniforms rot camZoom (tranx,trany) (winx,winy) 
+        ( extractProgAndUnis (_lightingFloorShader pdata) 
+        : extractProgAndUnis (_backgroundShader pdata) 
+        : extractProgAndUnis (_textureShader pdata)
+        : map extractProgAndUnis (_pictureShaders pdata)
+        )
+
+renderShader
+    :: Foldable f
+    => FullShader a
+    -> f a
+    -> IO Word32
+renderShader shad dat = do
+    sticks <- SDL.ticks
+    i <- F.foldM  (pokeShader shad) dat
+    bindShaderBuffers [shad] [i]
+    drawShader shad i
+    eticks <- SDL.ticks
+    return $ eticks - sticks
+
 renderFoldable
     :: Foldable f
     => RenderData

src/Shader.hs

@@ -70,7 +70,7 @@ bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
 bindArrayBuffers numVs ps = do
     forM_ ps $ \(bo,ptr,i) -> do
         bindBuffer ArrayBuffer $= Just bo
-        bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, StreamDraw)
+        bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, DynamicDraw)
 
 bindShaderBuffers :: [FullShader a] -> [Int] -> IO ()
 bindShaderBuffers = zipWithM_ f