justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Unify matrix uniform assignment, move towards uniform block

Browse Source
This commit is contained in:
jgk
2021-06-24 14:38:17 +02:00
parent 2625927f14
commit d534f08064
19 changed files with 70 additions and 91 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature.hs
+2 -2
View File
@@ -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
src/Dodge/Event.hs
+1 -1
View File
@@ -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
+2 -2
View File
@@ -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
}
src/Dodge/Item/Weapon/Booster.hs
+1 -1
View File
@@ -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
src/Dodge/Layout.hs
+1 -1
View File
@@ -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
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -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)
src/Dodge/Render.hs
+9 -14
View File
@@ -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
src/Dodge/Room/Foreground.hs
+10 -10
View File
@@ -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
src/Dodge/WorldEvent/Cloud.hs
+1 -1
View File
@@ -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))
src/Dodge/WorldEvent/Explosion.hs
+1 -1
View File
@@ -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
src/Picture.hs
+5 -5
View File
@@ -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 #-}
src/Picture/Data.hs
+1 -1
View File
@@ -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
src/Picture/Render.hs
+16 -14
View File
@@ -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
src/Picture/Tree.hs
+9 -26
View File
@@ -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)
src/Preload/Render.hs
+2 -2
View File
@@ -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]]
src/Shader.hs
+1 -2
View File
@@ -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
src/Shader/AuxAddition.hs
+3 -3
View File
@@ -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)
src/Shader/Compile.hs
+2 -2
View File
@@ -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
src/Tile.hs
+2 -2
View File
@@ -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