From d534f080642c5361efd7f132a04462a48ae1c186 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 24 Jun 2021 14:38:17 +0200 Subject: [PATCH] Unify matrix uniform assignment, move towards uniform block --- src/Dodge/Creature.hs | 4 ++-- src/Dodge/Event.hs | 2 +- src/Dodge/Item/Weapon.hs | 4 ++-- src/Dodge/Item/Weapon/Booster.hs | 2 +- src/Dodge/Layout.hs | 2 +- src/Dodge/LevelGen.hs | 2 +- src/Dodge/Render.hs | 23 ++++++++------------ src/Dodge/Room/Foreground.hs | 20 +++++++++--------- src/Dodge/WorldEvent/Cloud.hs | 2 +- src/Dodge/WorldEvent/Explosion.hs | 2 +- src/Picture.hs | 10 ++++----- src/Picture/Data.hs | 2 +- src/Picture/Render.hs | 30 +++++++++++++------------- src/Picture/Tree.hs | 35 ++++++++----------------------- src/Preload/Render.hs | 4 ++-- src/Shader.hs | 3 +-- src/Shader/AuxAddition.hs | 6 +++--- src/Shader/Compile.hs | 4 ++-- src/Tile.hs | 4 ++-- 19 files changed, 70 insertions(+), 91 deletions(-) diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index d7085bc04..d47f4d1d4 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -142,8 +142,8 @@ startCr :: Creature startCr = defaultCreature { _crPos = (0,0) , _crOldPos = (0,0) - , _crDir = (pi/2) - , _crMvDir = (pi/2) + , _crDir = pi/2 + , _crMvDir = pi/2 , _crID = 0 , _crPict = basicCrPict black , _crUpdate = stateUpdate yourControl diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 5fa03e058..9dde538d7 100644 --- a/src/Dodge/Event.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index c73d0fe98..bd47f90fd 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -830,7 +830,7 @@ explodeRemoteRocket -> World explodeRemoteRocket itid pjid w = set (projectiles . ix pjid . pjUpdate) (\_ -> retireRemoteRocket itid 30 pjid) - $ set (projectiles . ix pjid . pjDraw) (\_ -> blank) + $ set (projectiles . ix pjid . pjDraw) (const blank) $ set (itPoint . itUse) (\_ _ -> id) $ resetName $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w @@ -850,7 +850,7 @@ throwRemoteBomb cr w = setLocation { _pjPos = p , _pjStartPos = p , _pjVel = v - , _pjDraw = \_ -> blank + , _pjDraw = const blank , _pjID = i , _pjUpdate = \_ -> moveRemoteBomb itid 50 i } diff --git a/src/Dodge/Item/Weapon/Booster.hs b/src/Dodge/Item/Weapon/Booster.hs index 86aa8cbf8..2cb8ad283 100644 --- a/src/Dodge/Item/Weapon/Booster.hs +++ b/src/Dodge/Item/Weapon/Booster.hs @@ -97,7 +97,7 @@ drawBoostShockwave pj = setLayer 1 $ onLayer UPtLayer $ pictures $ r <- safeHead xs return $ color (snd $ last lpairs) $ uncurry translate hp $ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv - cols = map (flip withAlpha white) [0,0.05..] + cols = map (`withAlpha` white) [0,0.05..] lpairs = zip (reverse lps) cols pvs = _pjPoints pj t = _pjTimer pj diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index a56739d30..637e8c0b6 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -38,7 +38,7 @@ generateLevelFromRoomList gr w = updateWallZoning where plmnts = concatMap _rmPS rs rs = zipWith addTile zs rs' - zs = map fromIntegral $ randomRs (0,(63::Int)) $ _randGen w + zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w rs' = evalState gr $ _randGen w -- | connects a collection (tree) of rooms together diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 6ce6dbe94..7286e584d 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -81,7 +81,7 @@ placeSpot ps w = case _psType ps of PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w - PutBlock _ _ _ -> error "messed up block placement somehow" + PutBlock{} -> error "messed up block placement somehow" PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 02d1796c9..2f4128821 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -21,7 +21,7 @@ import Picture.Tree import Shader import Shader.Data import Shader.Poke -import MatrixHelper +--import MatrixHelper import Foreign (Word32) --import Control.Applicative @@ -59,10 +59,8 @@ doDrawing pdata w = do --setIsoMatrixUniforms pdata rot camzoom trans wins setPerpMatrixUniforms pdata rot camzoom trans wins viewFroms depthFunc $= Just Less - pmat <- (newMatrix RowMajor $ perspectiveMatrix rot camzoom trans wins viewFroms) - :: IO (GLmatrix GLfloat) -- draw the lightmap. Probably changes the bound framebufferObject - createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms pmat + createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms (foregroundPics w) -- -- set the coordinate uniforms ready for drawing elements using world coordinates @@ -78,11 +76,11 @@ doDrawing pdata w = do -- draw the walls depthFunc $= Just Less if w ^. config . wall_textured - then renderTextureWalls pdata wallPointsCol pmat - else renderBlankWalls pdata wallPointsCol pmat + then renderTextureWalls pdata wallPointsCol + else renderBlankWalls pdata wallPointsCol -- I believe a more apt name would be setCeilingDepth: stops drawing of objects -- at points that are behind the extension of walls to the screen edge - _ <- setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat + _ <- setWallDepth pdata wallPoints (viewFromx,viewFromy) -- draw the first layer of pictures -- these will probably all be opaque _ <- renderFoldable pdata $ picToLTree (Just 0) pic @@ -99,7 +97,7 @@ doDrawing pdata w = do depthMask $= Disabled -- render transparent walls -- the ordering between these and transparent clouds perhaps presents a challenge - renderBlankWalls pdata windowPoints pmat + renderBlankWalls pdata windowPoints depthMask $= Enabled forM_ (_pictureShaders pdata) $ setPerpMatUniform rot camzoom trans wins viewFroms @@ -138,13 +136,12 @@ doDrawing pdata w = do renderBlankWalls :: RenderData -> [((Point2,Point2),Point4)] -- ^ List: wall positions and color - -> GLmatrix GLfloat +-- -> GLmatrix GLfloat -> IO () -renderBlankWalls pdata wps pmat = do +renderBlankWalls pdata wps = do n <- F.foldM (pokeShader $ _wallBlankShader pdata) (map Render22x4 wps) bindShaderBuffers [_wallBlankShader pdata] [n] currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata) - uniform (_shaderMatrixUniform $ _wallBlankShader pdata) $= pmat cullFace $= Just Back drawShader (_wallBlankShader pdata) n cullFace $= Nothing @@ -152,13 +149,11 @@ renderBlankWalls pdata wps pmat = do renderTextureWalls :: RenderData -> [((Point2,Point2),Point4)] -- ^ List: wall positions and color - -> GLmatrix GLfloat -> IO () -renderTextureWalls pdata wps pmat = do +renderTextureWalls pdata wps = do n <- F.foldM (pokeShader $ _wallTextureShader pdata) (map Render22x4 wps) bindShaderBuffers [_wallTextureShader pdata] [n] currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata) - uniform (_shaderMatrixUniform $ _wallTextureShader pdata) $= pmat cullFace $= Just Back drawShader (_wallTextureShader pdata) n cullFace $= Nothing diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 6d1aa6c3b..750445a69 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -16,9 +16,9 @@ highDiagonalMesh -> Float -- ^ vertical distance between lines -> Picture highDiagonalMesh pa pb w d = setDepth (-0.2) $ pictures $ - (map (flip thickLine 3 . flat2) $ diagonalLinesRect pb pa w d (3*pi/4)) + map (flip thickLine 3 . flat2) (diagonalLinesRect pb pa w d (3*pi/4)) ++ - (map (flip thickLine 3 . flat2) $ diagonalLinesRect pb pc (negate h) d (pi/4)) + map (flip thickLine 3 . flat2) (diagonalLinesRect pb pc (negate h) d (pi/4)) where pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa)) h = dist pa pb @@ -42,7 +42,7 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints ,intersectSegLine' pa pax p (p +.+ diVec) ,intersectSegLine' pb pbx p (p +.+ diVec) ] - yN = d * 0.5 *.* (normalizeV $ pa -.- pb) + yN = d * 0.5 *.* normalizeV (pa -.- pb) highPipe :: Point2 -> Point2 -> Picture highPipe x y = pictures @@ -60,7 +60,7 @@ girderZ w x y = setDepth (-0.1) $ color red $ pictures $ ] ++ map (flip thickLine 3 . flat2) ls where - n = w *.* (normalizeV $ vNormal $ y -.- x) + n = w *.* normalizeV (vNormal $ y -.- x) xb = x +.+ n yb = y +.+ n xt = x -.- n @@ -77,27 +77,27 @@ girderV col w x y = setDepth (-0.1) $ color col $ pictures $ ++ map (flip thickLine 3 . flat2) as' ++ map (flip thickLine 3 . flat2) bs' where - n = w *.* (normalizeV $ vNormal $ y -.- x) + n = w *.* normalizeV (vNormal $ y -.- x) xb = x +.+ n yb = y +.+ n xt = x -.- n yt = y -.- n ps = divideLineExact (w*2) xb yb (as,_) = evenOddSplit ps - f a = map (\p -> intersectSegLine' xt yt p (p +.+ (rotateV a n))) + f a = map (\p -> intersectSegLine' xt yt p (p +.+ rotateV a n)) as' = catMaybes $ zipWith (fmap . (,)) as $ f (pi/4) as bs' = catMaybes $ zipWith (fmap . (,)) as $ f (3*pi/4) as girder :: Color -> Float -> Point2 -> Point2 -> Picture girder col w x y = pictures $ - [ setDepth (-0.1) $ color col $ pictures $ + (setDepth (-0.1) $ color col $ pictures $ [ thickLine [xt,yt] 3 , thickLine [xb,yb] 3 ] ++ map (flip thickLine 3 . flat2) ls - ] - ++ map (\p -> verticalPipe 1.5 col p 0 (-0.1)) [xb,xt,yb,yt] + ) + : map (\p -> verticalPipe 1.5 col p 0 (-0.1)) [xb,xt,yb,yt] where - n = w *.* (normalizeV $ vNormal $ y -.- x) + n = w *.* normalizeV (vNormal $ y -.- x) xb = x +.+ n yb = y +.+ n xt = x -.- n diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index bba1f232d..9e3374e48 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/src/Dodge/WorldEvent/Cloud.hs @@ -39,7 +39,7 @@ makeThinSmokeAt = makeCloudAt 5 400 (drawCloudWith 4 400 (withAlpha 0.05 black)) makeStartCloudAt :: Point2 -> World -> World --makeSmokeCloudAt = makeCloudAt 10 200 (drawCloudWith 2 200 (greyN 0.5)) -makeStartCloudAt = makeCloudAt 10 400 (drawCloudWith (2) 800 white) +makeStartCloudAt = makeCloudAt 10 400 (drawCloudWith 2 800 white) makeSmokeCloudAt :: Point2 -> World -> World --makeSmokeCloudAt = makeCloudAt 10 200 (drawCloudWith 2 200 (greyN 0.5)) diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index adcda728c..75a2b63b2 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -37,7 +37,7 @@ makeTeslaExplosionAt :: Point2 -- ^ Position -> World -> World -makeTeslaExplosionAt pos w = undefined pos w +makeTeslaExplosionAt = undefined -- soundOncePos grenadeBang pos $ foldr ($) w listOfFunctions -- a bit shorter -- where -- xs = randomRs (0, 2*pi) $ _randGen w diff --git a/src/Picture.hs b/src/Picture.hs index ff2a77764..4bc9fae97 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -122,7 +122,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) = color :: RGBA -> Picture -> Picture {-# INLINE color #-} -color c = OverPic id 0 (const c) +color c = OverPic id (const c) translate3 :: Float -> Float -> Point3 -> Point3 {-# INLINE translate3 #-} @@ -130,11 +130,11 @@ translate3 a b (x,y,z) = (x+a,y+b,z) translate :: Float -> Float -> Picture -> Picture {-# INLINE translate #-} -translate x y = OverPic (translate3 x y) 0 id +translate x y = OverPic (translate3 x y) id setDepth :: Float -> Picture -> Picture {-# INLINE setDepth #-} -setDepth d = OverPic (\(x,y,_) -> (x,y,d)) 0 id +setDepth d = OverPic (\(x,y,_) -> (x,y,d)) id setLayer :: Int -> Picture -> Picture {-# INLINE setLayer #-} @@ -146,7 +146,7 @@ scale3 a b (x,y,z) = (x*a,y*b,z) scale :: Float -> Float -> Picture -> Picture {-# INLINE scale #-} -scale x y = OverPic (scale3 x y) 0 id +scale x y = OverPic (scale3 x y) id rotate3 :: Float -> Point3 -> Point3 {-# INLINE rotate3 #-} @@ -156,7 +156,7 @@ rotate3 a (x,y,z) = (x',y',z) rotate :: Float -> Picture -> Picture {-# INLINE rotate #-} -rotate a = OverPic (rotate3 a) a id +rotate a = OverPic (rotate3 a) id pictures :: [Picture] -> Picture {-# INLINE pictures #-} diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index f9b780300..75d9ec4fe 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -86,7 +86,7 @@ data Picture | Line Int [Point2] | LineCol Int [(Point2,RGBA)] | Pictures [Picture] - | OverPic (Point3 -> Point3) Float (Point4 -> Point4) Picture + | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture | OnLayer Int Picture blank :: Picture diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index d2a12019b..5ed16dd9c 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -27,9 +27,8 @@ setWallDepth :: RenderData -> [(Point2,Point2)] -- ^ Wall points -> (Float,Float) -- ^ View from point - -> GLmatrix GLfloat -> IO Word32 -setWallDepth pdata wallPoints (viewFromx,viewFromy) _ = do +setWallDepth pdata wallPoints (viewFromx,viewFromy) = do startTicks <- SDL.ticks colorMask $= Color4 Disabled Disabled Disabled Disabled nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints) @@ -62,10 +61,9 @@ createLightMap -> [(Point2,Point2)] -- Wall pairs -> [Point4] -- Lights -> (Float,Float) -- View from position - -> GLmatrix GLfloat -- perspective matrix -> Picture -- foreground pictures -> IO () -createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _ = do +createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) _ = do -- get viewport size so we can reset it later (vppos,vpsize) <- get viewport @@ -79,9 +77,9 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _ nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints) bindShaderBuffers [_lightingOccludeShader pdata] [nWalls] -- set uniforms for shader that draws lights - currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata) - uniform (_shaderMatrixUniform $ _lightingWallShader pdata) - $= pmat +-- currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata) +-- uniform (_shaderMatrixUniform $ _lightingWallShader pdata) +-- $= pmat -- clear buffer to full alpha and furthest depth clearColor $= Color4 0 0 0 1 clearDepth $= 1 @@ -92,7 +90,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) $= pmat +-- uniform (_shaderMatrixUniform $ _lightingOccludeShader pdata) $= pmat cullFace $= Just Back drawShader (_lightingOccludeShader pdata) nWalls @@ -215,12 +213,16 @@ setPerpMatrixUniforms -> (Float,Float) -- ^ ViewFrom -> IO () setPerpMatrixUniforms pdata rot czoom trans wins vfs = mapM_ (setPerpMatUniform rot czoom trans wins vfs) - $ ( (_lightingFloorShader pdata) - : (_backgroundShader pdata) - : (_textureShader pdata) - : (_textureArrayShader pdata) - : (_pictureShaders pdata) - ) + ( _lightingFloorShader pdata + : _lightingWallShader pdata + : _lightingOccludeShader pdata + : _backgroundShader pdata + : _textureShader pdata + : _textureArrayShader pdata + : _wallBlankShader pdata + : _wallTextureShader pdata + : _pictureShaders pdata + ) renderShader :: Foldable f diff --git a/src/Picture/Tree.hs b/src/Picture/Tree.hs index 5f2a22589..d2e9e37ff 100644 --- a/src/Picture/Tree.hs +++ b/src/Picture/Tree.hs @@ -30,7 +30,6 @@ picToLTree mx (BezierQuad i vs) = filtB mx i $ LLeaf $ RenderBezQ $ zip3 (map ze where (ps,cols,offps,rads) = unzip4 vs rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads - picToLTree mx (Circle i colC colE r) = filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC) ,( (-r,-r,0), colE) @@ -53,24 +52,21 @@ picToLTree mx (Line i ps) picToLTree mx (LineCol i vs) = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs where (ps,cs) = unzip vs -picToLTree mx (Text i s) - = filtB mx i $ LLeaf $ RenderText $ stringToList s +picToLTree mx (Text i s) = filtB mx i $ LLeaf $ RenderText $ stringToList s picToLTree _ Blank = LBranches [] picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics -picToLTree j (OverPic f r f'' (OverPic g s g'' pic)) - = picToLTree j $ OverPic (f . g) (r + s) (f'' . g'') pic -picToLTree j (OverPic f r f'' (Pictures ps)) - = LBranches (map (picToLTree j . OverPic f r f'') ps) -picToLTree j (OverPic f r f'' pic) - = overPos f . overRot r . overCol f'' <$> picToLTree j pic +picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic +picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps) +picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic | otherwise = LBranches [] picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType {-# INLINE filtB #-} -filtB mx i t | Just i == mx || isNothing mx = t - | otherwise = LBranches [] +filtB mx i t + | Just i == mx || isNothing mx = t + | otherwise = LBranches [] doubleLine :: [a] -> [a] {-# INLINE doubleLine #-} @@ -91,10 +87,6 @@ overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs overPos f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs overPos _ _ = undefined -overRot :: Float -> RenderType -> RenderType -{-# INLINE overRot #-} -overRot _ ren = ren - overCol :: (Point4 -> Point4) -> RenderType -> RenderType {-# INLINE overCol #-} overCol f (RenderPoly vs) = RenderPoly $ map (second f) vs @@ -102,12 +94,12 @@ overCol f (RenderLine vs) = RenderLine $ map (second f) vs overCol f (RenderEllipse vs) = RenderEllipse $ map (second f) vs overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs overCol f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs -overCol f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs +overCol f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs overCol _ _ = undefined stringToList :: String -> [(Point3,Point4,Point2)] {-# INLINE stringToList #-} -stringToList s = concat $ zipWith (\x -> map (f x)) +stringToList s = concat $ zipWith (map . f) [0,0.9*dimText..] $ map charToTuple s where @@ -133,12 +125,3 @@ charToTuple c = translate3 :: Float -> Float -> Point3 -> Point3 {-# INLINE translate3 #-} translate3 a b (x,y,z) = (x+a,y+b,z) -{- Scale a 3D vector in the x and y directions. -} ---scale3 :: Float -> Float -> Point3 -> Point3 ---{-# INLINE scale3 #-} ---scale3 a b (x,y,z) = (x*a,y*b,z) ---{- Rotate a 3D vector in the x-y plane. -} ---rotate3 :: Float -> Point3 -> Point3 ---{-# INLINE rotate3 #-} ---rotate3 a (x,y,z) = (x',y',z) --- where (x',y') = rotateV a (x,y) diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 61442f6f6..745299b8f 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +--{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Preload.Render ( preloadRender @@ -167,7 +167,7 @@ pokeBezQStrat _ = [] {-# INLINE pokeTriStrat #-} pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType -> [[Float]] -pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> concat [flat3 p,flat4 co]) vs +pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> flat3 p ++ flat4 co) vs pokeTriStrat _ = [] pokeLightingFloorStrat :: RenderType -> [[Float]] diff --git a/src/Shader.hs b/src/Shader.hs index 9ed61c29b..16ce371e4 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -28,8 +28,7 @@ bindArrayBuffers :: Int -> VBO -> IO () bindArrayBuffers numVs theVBO = do bindBuffer ArrayBuffer $= Just (_vbo theVBO) bufferData ArrayBuffer $= - (fromIntegral $ floatSize * numVs * (sum $ _vboAttribSizes theVBO), _vboPointer theVBO, DynamicDraw) - + (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO), _vboPointer theVBO, DynamicDraw) bindShaderBuffers :: [FullShader] -> [Int] -> IO () bindShaderBuffers = zipWithM_ f diff --git a/src/Shader/AuxAddition.hs b/src/Shader/AuxAddition.hs index 1e096ede0..274a6ba8b 100644 --- a/src/Shader/AuxAddition.hs +++ b/src/Shader/AuxAddition.hs @@ -15,7 +15,7 @@ import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) -- I am not sure if this assumes that the shader is constructed directly before -- the texture is added... -addTexture :: String -> FullShader -> IO (FullShader) +addTexture :: String -> FullShader -> IO FullShader addTexture texturePath shad = do Right cmap <- readImage texturePath let tex = convertRGBA8 cmap @@ -31,7 +31,7 @@ addTexture texturePath shad = do textureFilter Texture2D $= ((Linear',Just Linear') , Nearest) return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb} -addTextureArray :: String -> FullShader -> IO (FullShader) +addTextureArray :: String -> FullShader -> IO FullShader addTextureArray texturePath shad = do Right cmap <- readImage texturePath let tex = convertRGBA8 cmap @@ -56,7 +56,7 @@ tilesToLine -> [a] tilesToLine w n = concat . concat . transpose . chunksOf n . chunksOf w -addUniforms :: [String] -> FullShader -> IO (FullShader) +addUniforms :: [String] -> FullShader -> IO FullShader addUniforms uniStrings shad = do uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings return $ shad & shaderCustomUnis %~ (++ uniLocs) diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index 577ff2eb2..d0a62daf9 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -23,7 +23,7 @@ makeShader -> [Int] -- ^ The input vertex sizes -> PrimitiveMode -> (RenderType -> [[Float]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound - -> IO (FullShader) + -> IO FullShader makeShader s shaderlist sizes pm renStrat = do (prog,unis) <- makeSourcedShader s shaderlist vaob <- setupVAO sizes @@ -57,7 +57,7 @@ setupVAO :: [Int] -> IO VAO setupVAO sizes = do theVAO <- genObjectName bindVertexArrayObject $= Just theVAO - theVBO <- setupVBO $ sizes + theVBO <- setupVBO sizes return $ VAO { _vao = theVAO , _vaoVBO = theVBO diff --git a/src/Tile.hs b/src/Tile.hs index f6eb90d01..7356b321e 100644 --- a/src/Tile.hs +++ b/src/Tile.hs @@ -10,7 +10,7 @@ tToRender t = map Render3x3 $ polyToTris $ zip ps3 coords3 where ps = _tilePoly t coords = map (calcTexCoord (_tileCenter t) (_tileX t) (_tileY t)) ps - ps3 = map (mkTrip (0.9)) ps + ps3 = map (mkTrip 0.9) ps coords3 = map (mkTrip (_tileZ t)) coords mkTrip :: c -> (a,b) -> (a,b,c) @@ -43,6 +43,6 @@ oTile poly z = Tile } where c = head poly - xdir = 50 *.* (normalizeV (poly !! 1 -.- c)) + xdir = 50 *.* normalizeV (poly !! 1 -.- c) x = c +.+ xdir y = c +.+ vNormal xdir