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

Work on textures and lighting

Browse Source
This commit is contained in:
justin
2023-03-23 21:17:24 +00:00
parent 1a2fc7c715
commit 1abfaa3cd0
25 changed files with 641 additions and 710 deletions
Download Patch File Download Diff File Expand all files Collapse all files
bench/Bench.hs
+8 -6
View File
@@ -1,6 +1,7 @@
import Criterion.Main import Criterion.Main
import Dodge.RandomHelp import RandomHelp
import Shader.Poke.Triangulate
import Geometry import Geometry
import Dodge.Creature.Inanimate import Dodge.Creature.Inanimate
@@ -13,24 +14,25 @@ import Data.List (zip4)
main :: IO () main :: IO ()
main = do main = do
[ps1, ps2, ps3, ps4] <- mapM randomPoints [5,10,50,500] --[ps1, ps2, ps3, ps4] <- mapM randomPoints [5,10,50,500]
[ps1, ps2,ps3] <- mapM randomPoints [5,10,50]
-- fs <- replicateM 500 (randomRIO (1,20)) -- fs <- replicateM 500 (randomRIO (1,20))
defaultMain defaultMain
[ bgroup "polyToTris tests" [ bgroup "polyToTris tests"
[ bench "polyToTris 5" $ nf polyToTris ps1 [ bench "polyToTris 5" $ nf ( polyToTris) ps1
, bench "polyToTris 10" $ nf polyToTris ps2 , bench "polyToTris 10" $ nf polyToTris ps2
, bench "polyToTris 50" $ nf polyToTris ps3 , bench "polyToTris 50" $ nf polyToTris ps3
, bench "polyToTris 500" $ nf polyToTris ps4 --, bench "polyToTris 500" $ nf polyToTris ps4
] ]
, bgroup "polyToTriFold tests" , bgroup "polyToTriFold tests"
[ bench "polyToTriFold 5" $ nf polyToTris'' ps1 [ bench "polyToTriFold 5" $ nf polyToTris'' ps1
, bench "polyToTriFold 10" $ nf polyToTris'' ps2 , bench "polyToTriFold 10" $ nf polyToTris'' ps2
, bench "polyToTriFold 50" $ nf polyToTris'' ps3 , bench "polyToTriFold 50" $ nf polyToTris'' ps3
, bench "polyToTriFold 500" $ nf polyToTris'' ps4 --, bench "polyToTriFold 500" $ nf polyToTris'' ps4
] ]
] ]
uncurry4 f (a,b,c,d) = f a b c d --uncurry4 f (a,b,c,d) = f a b c d
randomPoints :: Int -> IO [Point2] randomPoints :: Int -> IO [Point2]
randomPoints i = getStdGen <&> evalState (replicateM i $ randInCirc 500) randomPoints i = getStdGen <&> evalState (replicateM i $ randInCirc 500)
package.yaml
+1 -1
View File
@@ -116,7 +116,7 @@ benchmarks:
- -fno-liberate-case - -fno-liberate-case
- -fno-state-hack - -fno-state-hack
- -funfolding-use-threshold1000 - -funfolding-use-threshold1000
- -funfolding-keeness-factor1000 # - -funfolding-keeness-factor1000
- -fllvm - -fllvm
#- -optlo-O3 #- -optlo-O3
main: Bench.hs main: Bench.hs
shader/texture/bloomBlur.frag
+2
View File
@@ -33,6 +33,8 @@ void main()
{ {
sumFive += vec4(texture(screenTexture, vTexPos + fiveOff[i])); sumFive += vec4(texture(screenTexture, vTexPos + fiveOff[i]));
} }
//sumFive = sumFive * 3 * sin(dot(vTexPos,vTexPos) * 10000);
//fColor = vec4 ( max( (sumFive / 10) , texture(screenTexture,vTexPos) ) );
fColor = vec4 ( max( (sumFive / 10) , texture(screenTexture,vTexPos) ) ); fColor = vec4 ( max( (sumFive / 10) , texture(screenTexture,vTexPos) ) );
//fColor = max(texture(screenTexture,vTexPos), sumFive / 5); //fColor = max(texture(screenTexture,vTexPos), sumFive / 5);
//fColor = vec4 ( (sumFive / 5).rgb, max((sumFive/5.0).a,texture(screenTexture,vTexPos).a) ); //fColor = vec4 ( (sumFive / 5).rgb, max((sumFive/5.0).a,texture(screenTexture,vTexPos).a) );
shader/texture/simple.frag
+1 -1
View File
@@ -2,7 +2,7 @@
in vec2 vTexPos; in vec2 vTexPos;
out vec4 fColor; out vec4 fColor;
uniform sampler2D screenTexture; layout (binding = 0) uniform sampler2D screenTexture;
void main() void main()
{ {
src/Data/Preload/Render.hs
-4
View File
@@ -21,8 +21,6 @@ data RenderData = RenderData
, _shadowWallShader :: Shader , _shadowWallShader :: Shader
, _shadowLightShader :: (Shader,VBO) , _shadowLightShader :: (Shader,VBO)
, _shadowCombineShader :: (Shader,VBO) , _shadowCombineShader :: (Shader,VBO)
--, _positionalBlankShader :: (Shader,VBO)
, _wallBlankShader :: Shader
, _windowShader :: Shader , _windowShader :: Shader
, _fullscreenShader :: Shader , _fullscreenShader :: Shader
, _bloomBlurShader :: Shader , _bloomBlurShader :: Shader
@@ -53,8 +51,6 @@ data RenderData = RenderData
, _vboShapes :: VBO , _vboShapes :: VBO
, _floorVBO :: VBO , _floorVBO :: VBO
, _floorShader :: Shader , _floorShader :: Shader
, _texaNormalMaps :: TO
, _texaDiffuse :: TO
, _wallVBO :: VBO , _wallVBO :: VBO
, _wallShader :: Shader , _wallShader :: Shader
, _cloudVBO :: VBO , _cloudVBO :: VBO
src/Dodge/Creature/HandPos.hs
+30 -30
View File
@@ -49,12 +49,12 @@ translateToRightHand cr = translateToRightHand' cr -- . mirrorSPxz
translateToRightHand' :: Creature -> SPic -> SPic translateToRightHand' :: Creature -> SPic -> SPic
translateToRightHand' cr translateToRightHand' cr
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1) | oneH cr = shoulderSP . translateSPxy 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 4 (-10)
| twoFlat cr = waistSP . translateSPf 4 (-8) | twoFlat cr = waistSP . translateSPxy 4 (-8)
| otherwise = case cr ^? crStance . carriage of | otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) Just (Walking sa LeftForward) -> waistSP . translateSPxy (- f sa) (- off)
_ -> waistSP . translateSPf 0 (- off) _ -> waistSP . translateSPxy 0 (- off)
where where
off = 8 off = 8
sLen = _strideLength $ _crStance cr sLen = _strideLength $ _crStance cr
@@ -65,12 +65,12 @@ translateToRightWrist cr = translateToRightWrist' cr -- . mirrorSPxz
translateToRightWrist' :: Creature -> SPic -> SPic translateToRightWrist' :: Creature -> SPic -> SPic
translateToRightWrist' cr translateToRightWrist' cr
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1) | oneH cr = shoulderSP . translateSPxy 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) . offTrans | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 4 (-10) . offTrans
| twoFlat cr = waistSP . translateSPf 4 (-8) . offTrans | twoFlat cr = waistSP . translateSPxy 4 (-8) . offTrans
| otherwise = case cr ^? crStance . carriage of | otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) . offTrans Just (Walking sa LeftForward) -> waistSP . translateSPxy (- f sa) (- off) . offTrans
_ -> waistSP . translateSPf 0 (- off) . offTrans _ -> waistSP . translateSPxy 0 (- off) . offTrans
where where
offTrans = translateSP (V3 0 4 (-4)) offTrans = translateSP (V3 0 4 (-4))
off = 8 off = 8
@@ -92,12 +92,12 @@ translatePointToLeftHand cr
translateToLeftHand :: Creature -> SPic -> SPic translateToLeftHand :: Creature -> SPic -> SPic
translateToLeftHand cr translateToLeftHand cr
| oneH cr = waistSP . rotateSP 0.4 . translateSPf 0 off | oneH cr = waistSP . rotateSP 0.4 . translateSPxy 0 off
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 12 4
| twoFlat cr = waistSP . translateSPf 4 8 | twoFlat cr = waistSP . translateSPxy 4 8
| otherwise = case cr ^? crStance . carriage of | otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off Just (Walking sa RightForward) -> waistSP . translateSPxy (- f sa) off
_ -> waistSP . translateSPf 0 off _ -> waistSP . translateSPxy 0 off
where where
off = 8 off = 8
sLen = _strideLength $ _crStance cr sLen = _strideLength $ _crStance cr
@@ -105,12 +105,12 @@ translateToLeftHand cr
translateToLeftWrist :: Creature -> SPic -> SPic translateToLeftWrist :: Creature -> SPic -> SPic
translateToLeftWrist cr translateToLeftWrist cr
| oneH cr = waistSP . rotateSP 0.4 . translateSPf 0 off . offTrans | oneH cr = waistSP . rotateSP 0.4 . translateSPxy 0 off . offTrans
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 . offTrans | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 12 4 . offTrans
| twoFlat cr = waistSP . translateSPf 4 8 . offTrans | twoFlat cr = waistSP . translateSPxy 4 8 . offTrans
| otherwise = case cr ^? crStance . carriage of | otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off . offTrans Just (Walking sa RightForward) -> waistSP . translateSPxy (- f sa) off . offTrans
_ -> waistSP . translateSPf 0 off . offTrans _ -> waistSP . translateSPxy 0 off . offTrans
where where
offTrans = translateSP (V3 0 4 (-4)) offTrans = translateSP (V3 0 4 (-4))
off = 8 off = 8
@@ -120,9 +120,9 @@ translateToLeftWrist cr
translateToLeftLeg :: Creature -> SPic -> SPic translateToLeftLeg :: Creature -> SPic -> SPic
translateToLeftLeg cr = translateToLeftLeg cr =
rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf (f sa) off Just (Walking sa LeftForward) -> translateSPxy (f sa) off
Just (Walking sa RightForward) -> translateSPf (- f sa) off Just (Walking sa RightForward) -> translateSPxy (- f sa) off
_ -> translateSPf 0 off _ -> translateSPxy 0 off
where where
off = 5 off = 5
sLen = _strideLength $ _crStance cr sLen = _strideLength $ _crStance cr
@@ -131,9 +131,9 @@ translateToLeftLeg cr =
translateToRightLeg :: Creature -> SPic -> SPic translateToRightLeg :: Creature -> SPic -> SPic
translateToRightLeg cr = translateToRightLeg cr =
rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf (- f sa) (- off) Just (Walking sa LeftForward) -> translateSPxy (- f sa) (- off)
Just (Walking sa RightForward) -> translateSPf (f sa) (- off) Just (Walking sa RightForward) -> translateSPxy (f sa) (- off)
_ -> translateSPf 0 (- off) _ -> translateSPxy 0 (- off)
where where
off = 5 off = 5
sLen = _strideLength $ _crStance cr sLen = _strideLength $ _crStance cr
@@ -142,12 +142,12 @@ translateToRightLeg cr =
translateToHead :: Creature -> SPic -> SPic translateToHead :: Creature -> SPic -> SPic
translateToHead cr translateToHead cr
| twists cr = | twists cr =
translateSPz 20 . translateSPf 0 5 . rotateSP (-1) . translateSPf (negate 2.5) 0.25 translateSPz 20 . translateSPxy 0 5 . rotateSP (-1) . translateSPxy (negate 2.5) 0.25
. rotateSP 1 . rotateSP 1
| oneH cr = | oneH cr =
translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0 translateSPz 20 . rotateSP 0.5 . translateSPxy 2.5 0
. rotateSP (negate 0.5) . rotateSP (negate 0.5)
| otherwise = translateSPz 20 . translateSPf 2.5 0 | otherwise = translateSPz 20 . translateSPxy 2.5 0
translatePointToHead :: Creature -> Point3 -> Point3 translatePointToHead :: Creature -> Point3 -> Point3
translatePointToHead cr translatePointToHead cr
@@ -162,7 +162,7 @@ translatePointToHead cr
translateToChest :: Creature -> SPic -> SPic translateToChest :: Creature -> SPic -> SPic
translateToChest cr translateToChest cr
| oneH cr = rotateSP 0.5 | oneH cr = rotateSP 0.5
-- | twists cr = translateSPf 0 5 . rotateSP (-1) -- | twists cr = translateSPxy 0 5 . rotateSP (-1)
| twists cr = rotateSP (-1) | twists cr = rotateSP (-1)
| otherwise = id | otherwise = id
src/Dodge/Creature/Picture.hs
+1 -1
View File
@@ -23,7 +23,7 @@ import qualified Quaternion as Q
import ShapePicture import ShapePicture
basicCrPict :: Creature -> SPic basicCrPict :: Creature -> SPic
basicCrPict cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) basicCrPict cr = uncurryV translateSPxy (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
<> (basicCrShape cr, mempty) <> (basicCrShape cr, mempty)
--testShape :: Shape --testShape :: Shape
src/Dodge/Data/Config.hs
+4 -3
View File
@@ -39,7 +39,7 @@ data Configuration = Configuration
, _volume_sound :: Float , _volume_sound :: Float
, _volume_music :: Float , _volume_music :: Float
, _graphics_cloud_shadows :: Bool , _graphics_cloud_shadows :: Bool
, _graphics_object_shadows :: ObjectShadows , _graphics_object_shadows :: ShadowRendering
, _graphics_resolution_factor :: ResFactor , _graphics_resolution_factor :: ResFactor
, _graphics_num_shadow_casters :: NumShadowCasters , _graphics_num_shadow_casters :: NumShadowCasters
, _windowX :: Float , _windowX :: Float
@@ -84,7 +84,8 @@ data DebugBool
data ResFactor = FullRes | HalfRes | QuarterRes data ResFactor = FullRes | HalfRes | QuarterRes
deriving (Show, Eq, Ord, Enum, Bounded) deriving (Show, Eq, Ord, Enum, Bounded)
data ObjectShadows = GeoObjShads data ShadowRendering
= GeoObjShads
| InstancingShads | InstancingShads
| NoObjShads | NoObjShads
| NoShadows | NoShadows
@@ -125,7 +126,7 @@ debugOn db = S.member db . _debug_booleans
makeLenses ''Configuration makeLenses ''Configuration
deriveJSON defaultOptions ''NumShadowCasters deriveJSON defaultOptions ''NumShadowCasters
deriveJSON defaultOptions ''ResFactor deriveJSON defaultOptions ''ResFactor
deriveJSON defaultOptions ''ObjectShadows deriveJSON defaultOptions ''ShadowRendering
deriveJSON defaultOptions ''RoomClipping deriveJSON defaultOptions ''RoomClipping
deriveJSON defaultOptions ''DebugBool deriveJSON defaultOptions ''DebugBool
deriveJSON defaultOptions ''Configuration deriveJSON defaultOptions ''Configuration
src/Dodge/HeldUse.hs
+1 -1
View File
@@ -353,7 +353,7 @@ useMod hm = case hm of
moddelay x = itUse . heldConsumption . laAmmoType . amBullet . buDelayFraction .~ x moddelay x = itUse . heldConsumption . laAmmoType . amBullet . buDelayFraction .~ x
modcrpos x cr = modcrpos x cr =
cr & crDir %~ tweenAngles x (_crOldDir cr) cr & crDir %~ tweenAngles x (_crOldDir cr)
& crPos %~ tweenPoints x (_crOldPos cr) & crPos %~ alongSegBy x (_crOldPos cr)
mcUseHeld :: HeldItemType -> Item -> Machine -> World -> World mcUseHeld :: HeldItemType -> Item -> Machine -> World -> World
mcUseHeld hit = case hit of mcUseHeld hit = case hit of
src/Dodge/Projectile/Draw.hs
+1 -1
View File
@@ -34,7 +34,7 @@ drawRemoteShell pj
| t > (-99) = green | t > (-99) = green
| otherwise = red | otherwise = red
t = _prjTimer pj t = _prjTimer pj
doposition = translateSPz 18 . uncurryV translateSPf (_prjPos pj) . rotateSP (_prjDir pj) doposition = translateSPz 18 . uncurryV translateSPxy (_prjPos pj) . rotateSP (_prjDir pj)
remoteShellShape :: Color -> SPic remoteShellShape :: Color -> SPic
remoteShellShape col = remoteShellShape col =
src/Dodge/Prop/Draw.hs
+1 -1
View File
@@ -22,7 +22,7 @@ drawProp pd = case pd of
PropDrawToggle pd' -> propDrawToggle pd' PropDrawToggle pd' -> propDrawToggle pd'
PropDrawGib x -> noPic . drawGib x PropDrawGib x -> noPic . drawGib x
PropDrawFlatTranslate x -> \pr -> PropDrawFlatTranslate x -> \pr ->
uncurryV translateSPf (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr
drawGib :: Float -> Prop -> Shape drawGib :: Float -> Prop -> Shape
drawGib x pr = flesh <> skin drawGib x pr = flesh <> skin
src/Dodge/Render.hs
+16 -15
View File
@@ -5,6 +5,7 @@ module Dodge.Render (
--import qualified Data.Vector as V --import qualified Data.Vector as V
import Dodge.DownscaleSize
import Data.List (sortOn) import Data.List (sortOn)
import Shader.Poke.Cloud import Shader.Poke.Cloud
import GLHelp import GLHelp
@@ -187,14 +188,14 @@ doDrawing' win pdata u = do
--draw lightmap into its own buffer --draw lightmap into its own buffer
createLightMap createLightMap
cfig cfig
pdata (u ^. uvConfig . graphics_object_shadows)
lightPoints
nWalls nWalls
nSilIndices nSilIndices
nIndices nIndices
(u ^. uvConfig . graphics_object_shadows)
(pdata ^. fboBase . _2 . _2) (pdata ^. fboBase . _2 . _2)
(pdata ^. fboBase . _2 . _3) (pdata ^. fboBase . _2 . _3)
lightPoints
pdata
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
--apply lightmap to base buffer --apply lightmap to base buffer
glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase . _1 . unFBO) glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase . _1 . unFBO)
@@ -221,13 +222,14 @@ doDrawing' win pdata u = do
glDepthMask GL_TRUE glDepthMask GL_TRUE
renderLayer BloomLayer shadV layerCounts renderLayer BloomLayer shadV layerCounts
--setup downscale viewport for blurring bloom --setup downscale viewport for blurring bloom
setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact)) --setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact))
setViewportSize (round winx `div` downSize) (round winy `div` downSize)
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf1 pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf1 pdata)))
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO) glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO)
glDisable GL_BLEND glDisable GL_BLEND
drawShader (_bloomBlurShader pdata) 4 drawShader (_bloomBlurShader pdata) 4
replicateM_ 9 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata) replicateM_ 2 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
glEnable GL_BLEND glEnable GL_BLEND
setViewportSize (round winx `div` resFact) (round winy `div` resFact) setViewportSize (round winx `div` resFact) (round winy `div` resFact)
--draw clouds onto cloud buffer --draw clouds onto cloud buffer
@@ -302,21 +304,21 @@ doDrawing' win pdata u = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
createLightMap createLightMap
cfig cfig
pdata (_graphics_object_shadows $ _uvConfig u)
lightPoints
nWalls nWalls
nSilIndices nSilIndices
nIndices nIndices
(_graphics_object_shadows $ _uvConfig u)
(pdata ^. fboPos . _2) (pdata ^. fboPos . _2)
(pdata ^. fboCloud . _2 . _3) (pdata ^. fboCloud . _2 . _3)
lightPoints
pdata
glInvalidateBufferData (pdata ^. vboShapes . vboName) glInvalidateBufferData (pdata ^. vboShapes . vboName)
--apply lightmap to cloud buffer --apply lightmap to cloud buffer
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
glDepthMask GL_FALSE glDepthMask GL_FALSE
withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboLighting pdata) glBindTextureUnit 0 (_unTO . snd $ _fboLighting pdata)
glEnable GL_BLEND glEnable GL_BLEND
glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
@@ -326,20 +328,21 @@ doDrawing' win pdata u = do
--Draw blurred bloom onto base buffer --Draw blurred bloom onto base buffer
glEnable GL_BLEND glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE glBlendFunc GL_SRC_ALPHA GL_ONE
glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboHalf1 pdata) glBindTextureUnit 0 (_unTO . snd $ _fboHalf1 pdata)
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
--draw shadowed clouds onto base buffer --draw shadowed clouds onto base buffer
glBindTexture GL_TEXTURE_2D (pdata ^. fboCloud . _2 . _1 . unTO) glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _1 . unTO)
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
--set viewport for radial distortion --set viewport for radial distortion
setViewportSize (round winx) (round winy) setViewportSize (round winx) (round winy)
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glBlendFunc GL_ONE GL_ZERO glBlendFunc GL_ONE GL_ZERO
-- perform any radial distortion -- perform any radial distortion
-- this is hideous
case w ^. cWorld . lWorld . distortions of case w ^. cWorld . lWorld . distortions of
[] -> do [] -> do
bindTO $ pdata ^. fboBase . _2 . _1 glBindTextureUnit 0 $ pdata ^. fboBase . _2 . _1 . unTO
glBindFramebuffer GL_FRAMEBUFFER 0 glBindFramebuffer GL_FRAMEBUFFER 0
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
rds -> do rds -> do
@@ -352,10 +355,8 @@ doDrawing' win pdata u = do
take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata])) take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata]))
++ [FBO 0] ++ [FBO 0]
toList = (pdata ^. fboBase . _2 . _1) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata]) toList = (pdata ^. fboBase . _2 . _1) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata])
bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList) bindings = zipWith (>>) (map bindFBO fboList) (map (glBindTextureUnit 1 . _unTO) toList)
glActiveTexture GL_TEXTURE1
zipWithM_ (>>) bindings $ map bindDrawDist rds zipWithM_ (>>) bindings $ map bindDrawDist rds
glActiveTexture GL_TEXTURE1
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glEnable GL_BLEND glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
src/Dodge/Render/ShapePicture.hs
+14 -21
View File
@@ -2,8 +2,6 @@ module Dodge.Render.ShapePicture (
worldSPic, worldSPic,
) where ) where
import Dodge.Render.Picture
import Dodge.Data.Universe
import Control.Lens import Control.Lens
import Control.Monad (guard) import Control.Monad (guard)
import Data.Foldable import Data.Foldable
@@ -14,6 +12,7 @@ import qualified Data.Set as Set
import Dodge.Base import Dodge.Base
import Dodge.Creature.Picture import Dodge.Creature.Picture
import Dodge.Creature.Picture.Awareness import Dodge.Creature.Picture.Awareness
import Dodge.Data.Universe
import Dodge.Debug.Picture import Dodge.Debug.Picture
import Dodge.Draw import Dodge.Draw
import Dodge.Flare import Dodge.Flare
@@ -25,6 +24,7 @@ import Dodge.RadarBlip
import Dodge.Render.InfoBox import Dodge.Render.InfoBox
import Dodge.Render.Label import Dodge.Render.Label
import Dodge.Render.List import Dodge.Render.List
import Dodge.Render.Picture
import Dodge.ShortShow import Dodge.ShortShow
import Dodge.SoundLogic.LoadSound import Dodge.SoundLogic.LoadSound
import Dodge.Viewpoints import Dodge.Viewpoints
@@ -36,7 +36,7 @@ import Geometry.ConvexPoly
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Padding import Padding
import Picture import Picture
import Polyhedra import Shape
import ShapePicture import ShapePicture
import ShortShow import ShortShow
import Sound.Data import Sound.Data
@@ -108,21 +108,14 @@ drawCreature cr = case _crType cr of
] ]
) )
cr cr
Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr Lampoid{_lampHeight = h} -> uncurryV translateSPxy (_crPos cr) $ lampCrSPic h
NonDrawnCreature -> mempty NonDrawnCreature -> mempty
lampCrPic :: Float -> Picture lampCrSPic :: Float -> SPic
lampCrPic h = lampCrSPic h =
pictures ( colorSH blue . upperBox h $ rectWH 5 5
[ setLayer BloomLayer (setDepth h . color white $ circleSolid 3) , setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
, foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h -1) )
]
where
f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
picAtCrPosNoRot1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic
picAtCrPos1 :: Picture -> Creature -> SPic picAtCrPos1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-} --{-# INLINE picAtCrPos #-}
@@ -130,13 +123,13 @@ picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic
shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
shiftDraw fpos fdir fdraw x = shiftDraw fpos fdir fdraw x =
uncurryV translateSPf (fpos x) uncurryV translateSPxy (fpos x)
. rotateSP (fdir x) . rotateSP (fdir x)
$ fdraw x x $ fdraw x x
shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
shiftDraw' fpos fdir fdraw x = shiftDraw' fpos fdir fdraw x =
uncurryV translateSPf (fpos x) uncurryV translateSPxy (fpos x)
. rotateSP (fdir x) . rotateSP (fdir x)
$ fdraw x $ fdraw x
@@ -366,17 +359,17 @@ ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
floorItemSPic :: FloorItem -> SPic floorItemSPic :: FloorItem -> SPic
floorItemSPic flit = floorItemSPic flit =
uncurryV translateSPf (_flItPos flit) $ uncurryV translateSPxy (_flItPos flit) $
rotateSP (_flItRot flit) (itemSPic (_flIt flit)) rotateSP (_flItRot flit) (itemSPic (_flIt flit))
btSPic :: Button -> SPic btSPic :: Button -> SPic
btSPic bt = btSPic bt =
uncurryV translateSPf (_btPos bt) $ uncurryV translateSPxy (_btPos bt) $
rotateSP (_btRot bt) (drawButton (_btPict bt) bt) rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
mcSPic :: Machine -> SPic mcSPic :: Machine -> SPic
mcSPic mc = mcSPic mc =
uncurryV translateSPf (_mcPos mc) $ uncurryV translateSPxy (_mcPos mc) $
rotateSP (_mcDir mc) (drawMachine mc) rotateSP (_mcDir mc) (drawMachine mc)
soundPic :: Configuration -> World -> Sound -> Picture soundPic :: Configuration -> World -> Sound -> Picture
src/Framebuffer/Update.hs
+2 -1
View File
@@ -7,6 +7,7 @@ module Framebuffer.Update (
sizeFBOs, sizeFBOs,
) where ) where
import Dodge.DownscaleSize
import Shader.Data import Shader.Data
import Framebuffer.Check import Framebuffer.Check
import Control.Lens import Control.Lens
@@ -45,7 +46,7 @@ sizeFBOs xsize ysize xfull yfull rdata = do
[fbo2, fbo3] [fbo2, fbo3]
rdata4 <- rdata4 <-
foldM foldM
(updateFBOTO (xsize `div` 2) (ysize `div` 2) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F) (updateFBOTO (xfull `div` downSize) (yfull `div` downSize) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F)
rdata''' rdata'''
[fboHalf1, fboHalf2, fboHalf3] [fboHalf1, fboHalf2, fboHalf3]
newShadowFBO <- resizeShadowFBO (rdata ^. fboShadow) xsize ysize newShadowFBO <- resizeShadowFBO (rdata ^. fboShadow) xsize ysize
src/Geometry.hs
+147 -106
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{- | {- |
Module : Geometry Module : Geometry
Description : Geometry helpers Description : Geometry helpers
@@ -8,39 +9,42 @@ Conventions:
Seg refers to a segment, typically defined by two points, and will typically not extend beyond either of these points. Seg refers to a segment, typically defined by two points, and will typically not extend beyond either of these points.
Line refers to a line defined by two points, and extends beyond the two points. Line refers to a line defined by two points, and extends beyond the two points.
-} -}
module Geometry module Geometry (
( module Geometry module Geometry,
, module Geometry.Data module Geometry.Data,
, module Geometry.Intersect module Geometry.Intersect,
, module Geometry.Bezier module Geometry.Bezier,
, module Geometry.Vector module Geometry.Vector,
, module Geometry.Vector3D module Geometry.Vector3D,
, module Geometry.LHS module Geometry.LHS,
, module Geometry.Polygon module Geometry.Polygon,
, loopPairs module Geometry.Triangulate,
loopPairs,
) where ) where
import Geometry.Data
import Geometry.Polygon
import Geometry.Intersect
import Geometry.Bezier
import Geometry.Vector
import Geometry.Vector3D
import Geometry.LHS
import ListHelp
--import Geometry.ConvexPoly
import qualified Data.Set as S import qualified Data.Set as S
import Geometry.Bezier
import Geometry.Data
import Geometry.Intersect
import Geometry.LHS
import Geometry.Polygon
import Geometry.Triangulate
import Geometry.Vector
import Geometry.Vector3D
import ListHelp
--import Data.Maybe --import Data.Maybe
--import Data.List --import Data.List
-- | Return a point a distance away from a first point towards a second point.
-- Does not go past the second point. {- | Return a point a distance away from a first point towards a second point.
Does not go past the second point.
No check is made for a negative distance, so can go past the first point.
-}
alongSegBy :: Float -> Point2 -> Point2 -> Point2 alongSegBy :: Float -> Point2 -> Point2 -> Point2
alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a) alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
where where
y = min x $ dist a b y = min x $ dist a b
tweenPoints :: Float -> Point2 -> Point2 -> Point2
tweenPoints = alongSegBy
-- | Debug version of 'pointInPolygon'. -- | Debug version of 'pointInPolygon'.
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
errorPointInPolygon !i !p xs errorPointInPolygon !i !p xs
@@ -48,25 +52,30 @@ errorPointInPolygon !i !p xs
| length xs == 2 = error "two point polygon" | length xs == 2 = error "two point polygon"
| nub xs == xs = pointInPolygon p xs | nub xs == xs = pointInPolygon p xs
| otherwise = error $ "errorPointInPolygon " ++ show i | otherwise = error $ "errorPointInPolygon " ++ show i
-- | Debug version of 'normalizeV'. -- | Debug version of 'normalizeV'.
errorNormalizeV :: Int -> Point2 -> Point2 errorNormalizeV :: Int -> Point2 -> Point2
errorNormalizeV !i (V2 0 0) = error $ "problem with function: errorNormalizeV " ++ show i errorNormalizeV !i (V2 0 0) = error $ "problem with function: errorNormalizeV " ++ show i
errorNormalizeV _ !p = normalizeV p errorNormalizeV _ !p = normalizeV p
-- | Debug version of 'angleVV'. -- | Debug version of 'angleVV'.
errorAngleVV :: Int -> Point2 -> Point2 -> Float errorAngleVV :: Int -> Point2 -> Point2 -> Float
errorAngleVV !i (V2 0 0) _ = error $ "problem with function: errorAngleVV " ++ show i errorAngleVV !i (V2 0 0) _ = error $ "problem with function: errorAngleVV " ++ show i
errorAngleVV !i _ (V2 0 0) = error $ "problem with function: errorAngleVV " ++ show i errorAngleVV !i _ (V2 0 0) = error $ "problem with function: errorAngleVV " ++ show i
errorAngleVV _ !p !p' = angleVV p p' errorAngleVV _ !p !p' = angleVV p p'
-- | Debug version of 'isLHS'. -- | Debug version of 'isLHS'.
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
errorIsLHS !i !x !y errorIsLHS !i !x !y
| x == y = error $ "problem with function: errorIsLHS " ++ show i | x == y = error $ "problem with function: errorIsLHS " ++ show i
| otherwise = isLHS x y | otherwise = isLHS x y
-- | Debug version of 'closestPointOnLine' -- | Debug version of 'closestPointOnLine'
errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2 errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
errorClosestPointOnLine !i !x !y errorClosestPointOnLine !i !x !y
| x == y = error $ "problem with function: errorClosestPointOnLine " ++ show i | x == y = error $ "problem with function: errorClosestPointOnLine " ++ show i
| otherwise = closestPointOnLine x y | otherwise = closestPointOnLine x y
-- | Debug version of 'closestPointOnLineParam' -- | Debug version of 'closestPointOnLineParam'
errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
errorClosestPointOnLineParam _ !x !y !z errorClosestPointOnLineParam _ !x !y !z
@@ -76,53 +85,66 @@ errorClosestPointOnLineParam _ !x !y !z
-- | Return midpoint between two points. -- | Return midpoint between two points.
midPoint :: Point2 -> Point2 -> Point2 midPoint :: Point2 -> Point2 -> Point2
midPoint !a !b = 0.5 *.* (a +.+ b) midPoint !a !b = 0.5 *.* (a +.+ b)
-- | Test whether a circle is on a segment by intersecting a new normal segment through the
-- center of the circle with the segment itself. {- | Test whether a circle is on a segment by intersecting a new normal segment through the
-- Returns False if the circle center is beyond the endpoints of the center of the circle with the segment itself.
-- segment. Returns False if the circle center is beyond the endpoints of the
segment.
-}
circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnSegNoEndpoints #-} {-# INLINE circOnSegNoEndpoints #-}
circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-- | Test whether a circle is on a segment by intersecting a normal and testing
-- the distance to the endpoints of the segment. {- | Test whether a circle is on a segment by intersecting a normal and testing
-- Perhaps a better order of arguments. the distance to the endpoints of the segment.
Perhaps a better order of arguments.
-}
circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool
{-# INLINE circOnSeg #-} {-# INLINE circOnSeg #-}
circOnSeg !c !rad !p1 !p2 = magV (p1 -.- c) <= rad circOnSeg !c !rad !p1 !p2 =
magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad || magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
-- | Test whether a segment intersects a circle by intersecting a normal and testing {- | Test whether a segment intersects a circle by intersecting a normal and testing
-- the distance to the endpoints of the segment. the distance to the endpoints of the segment.
-}
segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE segOnCirc #-} {-# INLINE segOnCirc #-}
segOnCirc !p1 !p2 !c !rad = magV (p1 -.- c) <= rad segOnCirc !p1 !p2 !c !rad =
magV (p1 -.- c) <= rad
|| magV (p2 -.- c) <= rad || magV (p2 -.- c) <= rad
|| intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
where where
thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool
{-# INLINE cylinderOnSeg #-} {-# INLINE cylinderOnSeg #-}
cylinderOnSeg = undefined cylinderOnSeg = undefined
-- | Find the difference between two Nums. -- | Find the difference between two Nums.
difference :: (Ord a, Num a) => a -> a -> a difference :: (Ord a, Num a) => a -> a -> a
{-# INLINE difference #-} {-# INLINE difference #-}
difference x y difference x y
| x > y = x - y | x > y = x - y
| otherwise = y - x | otherwise = y - x
-- | Given vector line direction and a vector movement,
-- reflects the movement according to the line. {- | Given vector line direction and a vector movement,
reflects the movement according to the line.
-}
reflectIn :: Point2 -> Point2 -> Point2 reflectIn :: Point2 -> Point2 -> Point2
reflectIn line vec = rotateV (2 * angleBetween line vec) vec reflectIn line vec = rotateV (2 * angleBetween line vec) vec
-- | Find angle between two points. {- | Find angle between two points.
-- Not normalised, ranges from -2*pi to 2*pi. Not normalised, ranges from -2*pi to 2*pi.
-}
angleBetween :: Point2 -> Point2 -> Float angleBetween :: Point2 -> Point2 -> Float
angleBetween v1 v2 = argV v1 - argV v2 angleBetween v1 v2 = argV v1 - argV v2
-- | Return a list containing two copies of a pair. -- | Return a list containing two copies of a pair.
doublePair :: (a, a) -> [(a, a)] doublePair :: (a, a) -> [(a, a)]
doublePair (x, y) = [(x, y), (y, x)] doublePair (x, y) = [(x, y), (y, x)]
@@ -133,22 +155,7 @@ doublePairSet (x,y) = S.fromList [(x,y),(y,x)]
doubleV2 :: V2 a -> [V2 a] doubleV2 :: V2 a -> [V2 a]
doubleV2 (V2 x y) = [V2 x y, V2 y x] doubleV2 (V2 x y) = [V2 x y, V2 y x]
-- split a list into triples, forms triangles from a polygon
polyToTris'' :: [s] -> [s]
polyToTris'' (a:as) = go a as
where
go !x (y:z:ys) = x : y : z : go x (z:ys)
go _ _ = []
polyToTris'' _ = []
polyToTris :: [s] -> [s]
{-# INLINABLE polyToTris #-}
--polyToTris (x:xs) = foldr (f x) [] $ foldPairs xs
polyToTris (x:xs) = foldl' (flip $ f x) [] $ zip xs $ tail xs
--polyToTris (x:xs) = foldr (f x) [] $ zip xs $ tail xs
where
f a (b,c) ls = a:b:c:ls
polyToTris _ = []
polyToTris' :: [s] -> [s] polyToTris' :: [s] -> [s]
{-# INLINE polyToTris' #-} {-# INLINE polyToTris' #-}
@@ -162,23 +169,30 @@ prependTwo _ _ = []
-- | Return n equidistant points on a circle with a radius of 600. -- | Return n equidistant points on a circle with a radius of 600.
nRays :: Int -> [Point2] nRays :: Int -> [Point2]
nRays n = nRaysRad n 600 nRays n = nRaysRad n 600
-- | Return n equidistant points on a circle with a radius of x. -- | Return n equidistant points on a circle with a radius of x.
nRaysRad :: Int -> Float -> [Point2] nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2 * pi / fromIntegral n)) (V2 x 0) nRaysRad n x = take n $ iterate (rotateV (2 * pi / fromIntegral n)) (V2 x 0)
-- | Test whether an angle is to the left of another angle, according to the
-- smallest change in rotation between them. {- | Test whether an angle is to the left of another angle, according to the
-- This appears to sometimes fail if the angles are not normalized. smallest change in rotation between them.
This appears to sometimes fail if the angles are not normalized.
-}
isLeftOfA :: Float -> Float -> Bool isLeftOfA :: Float -> Float -> Bool
--isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2) --isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2)
-- || (angle2 - angle1 > pi && angle2 > angle1) -- || (angle2 - angle1 > pi && angle2 > angle1)
isLeftOfA angle1 angle2 = normalizeAngle (angle1 - angle2) < pi isLeftOfA angle1 angle2 = normalizeAngle (angle1 - angle2) < pi
-- | Test whether a vector is to the left of another, according to the smallest
-- change of rotation between them. {- | Test whether a vector is to the left of another, according to the smallest
change of rotation between them.
-}
isLeftOf :: Point2 -> Point2 -> Bool isLeftOf :: Point2 -> Point2 -> Bool
isLeftOf x y = isLeftOfA (argV x) (argV y) isLeftOf x y = isLeftOfA (argV x) (argV y)
-- | Find the difference between two angles.
-- Possibly not correct... {- | Find the difference between two angles.
-- TODO write tests Possibly not correct...
TODO write tests
-}
diffAngles :: Float -> Float -> Float diffAngles :: Float -> Float -> Float
diffAngles x y diffAngles x y
| diff > pi = diffAngles (x - 2 * pi) y | diff > pi = diffAngles (x - 2 * pi) y
@@ -201,8 +215,9 @@ pointInCircle p r c
| magV (p -.- c) < r = Just p | magV (p -.- c) < r = Just p
| otherwise = Nothing | otherwise = Nothing
-- | Finds the height of a triangle using herons formula. {- | Finds the height of a triangle using herons formula.
-- The base is the line between the first two points. The base is the line between the first two points.
-}
heron :: Point2 -> Point2 -> Point2 -> Float heron :: Point2 -> Point2 -> Point2 -> Float
heron x y z heron x y z
| x == y = 0 | x == y = 0
@@ -213,6 +228,7 @@ heron x y z
s = (a + b + c) / 2 s = (a + b + c) / 2
area = sqrt (s * (s - a) * (s - b) * (s - c)) area = sqrt (s * (s - a) * (s - b) * (s - c))
in 2 * area / a in 2 * area / a
-- | Multiplies reflection in normal by factor. -- | Multiplies reflection in normal by factor.
reflectInParam :: Float -> Point2 -> Point2 -> Point2 reflectInParam :: Float -> Point2 -> Point2 -> Point2
reflectInParam x line vec = reflectInParam x line vec =
@@ -226,24 +242,31 @@ isOnSeg l1 l2 p =
errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
&& errorClosestPointOnLineParam 11 l1 l2 p <= 1 && errorClosestPointOnLineParam 11 l1 l2 p <= 1
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0 && errorClosestPointOnLineParam 12 l1 l2 p >= 0
-- | Divide a segment into a list of points with a maximal distance between
-- them. {- | Divide a segment into a list of points with a maximal distance between
-- the take 5000 here is a hack, otherwise divideLine seems to sometimes them.
-- generate an infinite list, and I don't know why the take 5000 here is a hack, otherwise divideLine seems to sometimes
generate an infinite list, and I don't know why
-}
divideLine :: Float -> Point2 -> Point2 -> [Point2] divideLine :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLine x a b = take 5000 divideLine x a b =
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) take 5000 $
map
(\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)))
ns ns
where where
d = dist a b d = dist a b
numPoints = max 1 $ ceiling $ d / x numPoints = max 1 $ ceiling $ d / x
ns = [0 :: Int .. numPoints] ns = [0 :: Int .. numPoints]
-- | As 'divideLine', but must return an odd number of points. -- | As 'divideLine', but must return an odd number of points.
divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2] divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLineOddNumPoints x a b = take 5000 divideLineOddNumPoints x a b =
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) take 5000 $
map
(\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)))
ns ns
where where
d = dist a b d = dist a b
@@ -259,9 +282,9 @@ divideLineExact x a b = map ( (a +.+ ) . ( *.* v) ) [0 , x .. d]
d = dist a b d = dist a b
v = normalizeV $ b -.- a v = normalizeV $ b -.- a
{- | Given two pairs of Ints, returns a list of pairs of Ints that form
-- | Given two pairs of Ints, returns a list of pairs of Ints that form a digital line between them.
-- a digital line between them. -}
digitalLine :: (Int, Int) -> (Int, Int) -> [(Int, Int)] digitalLine :: (Int, Int) -> (Int, Int) -> [(Int, Int)]
--{-# INLINE digitalLine #-} --{-# INLINE digitalLine #-}
digitalLine (x1, y1) (x2, y2) digitalLine (x1, y1) (x2, y2)
@@ -275,8 +298,10 @@ digitalLine (x1,y1) (x2,y2)
] ]
where where
rdiv a b = round $ fromIntegral a / (fromIntegral b :: Float) rdiv a b = round $ fromIntegral a / (fromIntegral b :: Float)
-- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a
-- rectangle between them. {- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a
rectangle between them.
-}
digitalRect :: (Int, Int) -> (Int, Int) -> [(Int, Int)] digitalRect :: (Int, Int) -> (Int, Int) -> [(Int, Int)]
{-# INLINE digitalRect #-} {-# INLINE digitalRect #-}
digitalRect (a, b) (c, d) = [(s, t) | s <- [minx .. maxx], t <- [miny .. maxy]] digitalRect (a, b) (c, d) = [(s, t) | s <- [minx .. maxx], t <- [miny .. maxy]]
@@ -285,35 +310,46 @@ digitalRect (a,b) (c,d) = [(s,t) | s <- [minx .. maxx] , t <- [miny .. maxy]]
minx = min a c minx = min a c
maxy = max b d maxy = max b d
miny = min b d miny = min b d
-- | Given two Ints, creates the list of Ints between these. -- | Given two Ints, creates the list of Ints between these.
intervalList :: Int -> Int -> [Int] intervalList :: Int -> Int -> [Int]
{-# INLINE intervalList #-} {-# INLINE intervalList #-}
intervalList x y intervalList x y
| y > x = [x .. y] | y > x = [x .. y]
| otherwise = reverse [y .. x] | otherwise = reverse [y .. x]
-- | Create points on the circumference of a circle with maximal distance
-- between them. {- | Create points on the circumference of a circle with maximal distance
between them.
-}
divideCircle :: Float -> Point2 -> Float -> [Point2] divideCircle :: Float -> Point2 -> Float -> [Point2]
divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad
where where
n = ceiling $ rad * 2 * pi / x n = ceiling $ rad * 2 * pi / x
arcStepwise arcStepwise ::
:: Float -- ^ Maximum distance between points -- | Maximum distance between points
-> Float -- ^ Angle to travel Float ->
-> Point2 -- ^ Center -- | Angle to travel
-> Point2 -- ^ Start vector from center Float ->
-> [Point2] -- | Center
Point2 ->
-- | Start vector from center
Point2 ->
[Point2]
arcStepwise ssize a c v arcStepwise ssize a c v
| a < 0 = reverse $ arcStepwisePositive ssize (negate a) c (rotateV a v) | a < 0 = reverse $ arcStepwisePositive ssize (negate a) c (rotateV a v)
| otherwise = arcStepwisePositive ssize a c v | otherwise = arcStepwisePositive ssize a c v
arcStepwisePositive arcStepwisePositive ::
:: Float -- ^ Maximum distance between points -- | Maximum distance between points
-> Float -- ^ Angle to travel, assumed to be positive Float ->
-> Point2 -- ^ Center -- | Angle to travel, assumed to be positive
-> Point2 -- ^ Start vector from center Float ->
-> [Point2] -- | Center
Point2 ->
-- | Start vector from center
Point2 ->
[Point2]
arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots
where where
rots :: [Float] rots :: [Float]
@@ -321,25 +357,30 @@ arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots
n :: Int n :: Int
n = ceiling (a * magV v / ssize) n = ceiling (a * magV v / ssize)
-- | Given a list of points, returns pairs of points linking the points into a {- | Given a list of points, returns pairs of points linking the points into a
-- loop. loop.
-}
chainPairs :: [Point2] -> [(Point2, Point2)] chainPairs :: [Point2] -> [(Point2, Point2)]
chainPairs [] = error "tried to make chain with empty list of points" chainPairs [] = error "tried to make chain with empty list of points"
chainPairs [_] = error "tried to make chain with singleton list of points" chainPairs [_] = error "tried to make chain with singleton list of points"
chainPairs xs = zip xs $ tail xs chainPairs xs = zip xs $ tail xs
-- | Given a list of points, returns pairs of points linking the points into a {- | Given a list of points, returns pairs of points linking the points into a
-- loop. loop.
--loopPairs :: [a] -> [(a,a)] loopPairs :: [a] -> [(a,a)]
--loopPairs [] = error "tried to make loop with empty list of elements" loopPairs [] = error "tried to make loop with empty list of elements"
--loopPairs [_] = error "tried to make loop with singleton list of elements" loopPairs [_] = error "tried to make loop with singleton list of elements"
--loopPairs (x:xs) = zip (x:xs) (xs ++ [x]) loopPairs (x:xs) = zip (x:xs) (xs ++ [x])
-- | Test whether a point is in a cone. | Test whether a point is in a cone.
-- Note the pair is ordered. Note the pair is ordered.
-- Doesn't work for obtuse angles. Doesn't work for obtuse angles.
pointIsInCone -}
:: Point2 -- ^ Cone point. pointIsInCone ::
-> (Point2,Point2) -- ^ Points delimiting the left and right boundaries of the cone. -- | Cone point.
-> Point2 -- ^ Point to test. Point2 ->
-> Bool -- | Points delimiting the left and right boundaries of the cone.
(Point2, Point2) ->
-- | Point to test.
Point2 ->
Bool
pointIsInCone c (rightp, leftp) p = isLHS c rightp p && isLHS leftp c p pointIsInCone c (rightp, leftp) p = isLHS c rightp p && isLHS leftp c p
src/Preload/Render.hs
+13 -18
View File
@@ -127,15 +127,15 @@ preloadRender = do
poke (shadVBOptr shadowlightshader) 1 poke (shadVBOptr shadowlightshader) 1
-- 2D draw shaders -- 2D draw shaders
bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles bslist <- makeShaderVBO "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles
bslista <- makeShader4 "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp pmTriangles shVBO bslista <- makeShaderUsingVBO "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp pmTriangles shVBO
glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) (shEBO' ^. eboName) glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) (shEBO' ^. eboName)
--glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) shEBOname --glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) shEBOname
aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles aslist <- makeShaderVBO "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles
eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles eslist <- makeShaderVBO "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles
cslist <- cslist <-
makeShader "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles makeShaderVBO "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles
addBindTextureArray 50 "data/texture/charMapVert.png" 2 16 32 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR initTexture2DArray 50 "data/texture/charMapVert.png" 2 16 32 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR
screentexturevbo <- mglCreate glCreateBuffers screentexturevbo <- mglCreate glCreateBuffers
withArray (concat cornerList) $ \ptr -> withArray (concat cornerList) $ \ptr ->
@@ -145,26 +145,24 @@ preloadRender = do
ptr ptr
0 0
screentexturevao <- setupVAOvbo' [2,2] 4 screentexturevbo screentexturevao <- setupVAOvbo' [2,2] 4 screentexturevbo
alphadivideshader <- makeShader4UsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao alphadivideshader <- makeShaderUsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao
fsShad <- makeShader4UsingVAO "texture/simple" [vert, frag] pmTriangleStrip screentexturevao fsShad <- makeShaderUsingVAO "texture/simple" [vert, frag] pmTriangleStrip screentexturevao
bloomBlurShad <- makeShaderUsingVAO "texture/bloomBlur" [vert, frag] pmTriangleStrip screentexturevao bloomBlurShad <- makeShaderUsingVAO "texture/bloomBlur" [vert, frag] pmTriangleStrip screentexturevao
colorBlurShad <- makeShaderUsingVAO "texture/colorBlur" [vert, frag] pmTriangleStrip screentexturevao colorBlurShad <- makeShaderUsingVAO "texture/colorBlur" [vert, frag] pmTriangleStrip screentexturevao
grayscaleShad <- makeShaderUsingVAO "texture/grayscale" [vert, frag] pmTriangleStrip screentexturevao grayscaleShad <- makeShaderUsingVAO "texture/grayscale" [vert, frag] pmTriangleStrip screentexturevao
lightingTextureShad <- lightingTextureShad <-
makeShaderUsingVAO "lighting/texture" [vert, frag] pmTriangleStrip screentexturevao makeShaderUsingVAO "lighting/texture" [vert, frag] pmTriangleStrip screentexturevao
barrelShad <- makeShader "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] pmPoints barrelShad <- makeShaderVBO "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] pmPoints
-- blank wallShader -- blank wallShader
wallBlankShad <- makeShaderUsingVAO "wall/blank" [vert, geom, frag] pmPoints wpColVAO wallBlankShad <- makeShaderUsingVAO "wall/blank" [vert, geom, frag] pmPoints wpColVAO
let wallverxstrd = 8 let wallverxstrd = 8
wallvbo <- setupVBO wallverxstrd wallvbo <- setupVBO wallverxstrd
wallshader <- makeShader4 "wall/basic" [vert,geom,frag] [4,4] wallverxstrd pmPoints wallvbo wallshader <- makeShaderUsingVBO "wall/basic" [vert,geom,frag] [4,4] wallverxstrd pmPoints wallvbo
let floorverxstrd = 8 let floorverxstrd = 8
floorvbo <- setupVBOStatic floorverxstrd floorvbo <- setupVBOStatic floorverxstrd
floorshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4] floorverxstrd pmTriangles floorvbo floorshader <- makeShaderUsingVBO "floor/arrayPos" [vert, frag] [4,4] floorverxstrd pmTriangles floorvbo
todiffusemap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png" initTexture2DArraySquare 40 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png"
tonormalmap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png" initTexture2DArraySquare 41 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png"
glBindTextureUnit 40 (todiffusemap ^. unTO)
glBindTextureUnit 41 (tonormalmap ^. unTO)
let cloudverxsizes = [4,4,4,4] let cloudverxsizes = [4,4,4,4]
cloudvbo <- setupVBO (sum cloudverxsizes) cloudvbo <- setupVBO (sum cloudverxsizes)
@@ -220,7 +218,6 @@ preloadRender = do
, _shadowWallShader = shadowwallshader , _shadowWallShader = shadowwallshader
, _shadowLightShader = shadowlightshader , _shadowLightShader = shadowlightshader
, _shadowCombineShader = shadowcombineshader , _shadowCombineShader = shadowcombineshader
, _wallBlankShader = wallBlankShad
, _windowShader = wallBlankShad{_shaderVAO = winColVAO} , _windowShader = wallBlankShad{_shaderVAO = winColVAO}
, _fullscreenShader = fsShad , _fullscreenShader = fsShad
, _alphaDivideShader = alphadivideshader , _alphaDivideShader = alphadivideshader
@@ -249,8 +246,6 @@ preloadRender = do
, _vboShapes = shVBO , _vboShapes = shVBO
, _floorVBO = floorvbo , _floorVBO = floorvbo
, _floorShader = floorshader , _floorShader = floorshader
, _texaNormalMaps = tonormalmap
, _texaDiffuse = todiffusemap
, _wallVBO = wallvbo , _wallVBO = wallvbo
, _wallShader = wallshader , _wallShader = wallshader
, _cloudVBO = cloudvbo , _cloudVBO = cloudvbo
src/Render.hs
+50 -43
View File
@@ -2,7 +2,6 @@ module Render (
createLightMap, createLightMap,
renderLayer, renderLayer,
pingPongBetween, pingPongBetween,
bindTO,
bindFBO, bindFBO,
) where ) where
@@ -28,8 +27,7 @@ import Shader.Data
-} -}
createLightMap :: createLightMap ::
Configuration -> Configuration ->
RenderData -> ShadowRendering ->
[(Point3, Float, Point3)] -> -- Lights
-- | number of walls -- | number of walls
Int -> Int ->
@@ -37,19 +35,26 @@ createLightMap ::
Int -> Int ->
-- | number of "caps" to attempt to draw -- | number of "caps" to attempt to draw
Int -> Int ->
-- | whether to draw object shadows or not
ObjectShadows ->
-- | the texture object giving positions -- | the texture object giving positions
TO -> TO ->
-- | the texture object giving normals -- | the texture object giving normals
TO -> TO ->
[(Point3, Float, Point3)] -> -- Lights
RenderData ->
IO () IO ()
createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype createLightMap cfig shadrendertype = case shadrendertype of
positiontexture InstancingShads -> instanceLightMap cfig
normaltexture NoShadows -> const . const . const renderLightingNoShadows
= case shadsdrawtype of NoLighting -> const . const . const . const . const . const renderFlatLighting
InstancingShads -> instanceLightMap cfig pdata lightPoints nWalls nSils nCaps positiontexture _ -> renderShadows shadrendertype
NoShadows -> do
renderLightingNoShadows ::
TO ->
TO ->
[(V3 GLfloat, GLfloat, V3 GLfloat)] ->
RenderData ->
IO ()
renderLightingNoShadows positiontexture normaltexture lightPoints pdata = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let ltextShad = _lightingTextureShader pdata let ltextShad = _lightingTextureShader pdata
-- we assume that the renderbuffer's depth has been correctly set elsewhere -- we assume that the renderbuffer's depth has been correctly set elsewhere
@@ -57,7 +62,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
glDepthMask GL_FALSE glDepthMask GL_FALSE
-- clearColor is specified differently in preloadRender -- clearColor is specified differently in preloadRender
-- the colors are inverted -- the colors are inverted
withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv withArray [1, 1, 1, 1] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO) (pdata ^. fboLighting . _1 . unFBO)
GL_COLOR GL_COLOR
0 0
@@ -74,7 +80,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
glDepthFunc GL_LESS glDepthFunc GL_LESS
-- setup stencil -- setup stencil
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
with 0 $ \ptr -> glClearNamedFramebufferiv with 0 $ \ptr ->
glClearNamedFramebufferiv
(pdata ^. fboLighting . _1 . unFBO) (pdata ^. fboLighting . _1 . unFBO)
GL_STENCIL GL_STENCIL
0 0
@@ -85,6 +92,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
-- bind world position texture -- bind world position texture
glBindTextureUnit 0 (positiontexture ^. unTO) glBindTextureUnit 0 (positiontexture ^. unTO)
glBindTextureUnit 1 (normaltexture ^. unTO)
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255 glStencilFunc GL_EQUAL 0 255
glUseProgram (ltextShad ^. shaderUINT) glUseProgram (ltextShad ^. shaderUINT)
@@ -98,24 +106,27 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
--cleanup: may not be necessary, depending on what comes after... --cleanup: may not be necessary, depending on what comes after...
glDisable GL_CULL_FACE glDisable GL_CULL_FACE
glDisable GL_STENCIL_TEST glDisable GL_STENCIL_TEST
NoLighting -> do
renderFlatLighting :: RenderData -> IO ()
renderFlatLighting pdata = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR withArray [1, 1, 1, 1] $ \ptr ->
withArray [0,0,0,1] $ \ptr -> glClearNamedFramebufferfv glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO) (pdata ^. fboLighting . _1 . unFBO)
GL_COLOR GL_COLOR
0 0
ptr ptr
with 1 $ \ptr -> glClearNamedFramebufferfv with 1 $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO) (pdata ^. fboLighting . _1 . unFBO)
GL_DEPTH GL_DEPTH
0 0
ptr ptr
glDisable GL_CULL_FACE glDisable GL_CULL_FACE
glBindTextureUnit 0 (positiontexture ^. unTO)
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glDepthMask GL_FALSE glDepthMask GL_FALSE
_ -> do
renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture lightPoints pdata = do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let llinesShad = _lightingLineShadowShader pdata let llinesShad = _lightingLineShadowShader pdata
lcapShad = _lightingCapShader pdata lcapShad = _lightingCapShader pdata
@@ -126,7 +137,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
glDepthMask GL_FALSE glDepthMask GL_FALSE
-- clearColor is specified differently in preloadRender -- clearColor is specified differently in preloadRender
-- the colors are inverted -- the colors are inverted
withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv withArray [1, 1, 1, 1] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO) (pdata ^. fboLighting . _1 . unFBO)
GL_COLOR GL_COLOR
0 0
@@ -143,7 +155,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
glDepthFunc GL_LESS glDepthFunc GL_LESS
-- setup stencil -- setup stencil
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
with 0 $ \ptr -> glClearNamedFramebufferiv with 0 $ \ptr ->
glClearNamedFramebufferiv
(pdata ^. fboLighting . _1 . unFBO) (pdata ^. fboLighting . _1 . unFBO)
GL_STENCIL GL_STENCIL
0 0
@@ -159,7 +172,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype
(_unPrimitiveMode $ _shaderPrimitive lwallShad) (_unPrimitiveMode $ _shaderPrimitive lwallShad)
0 0
(fromIntegral nWalls) (fromIntegral nWalls)
case shadsdrawtype of case shadrendertype of
GeoObjShads -> do GeoObjShads -> do
--draw silhouette shadows --draw silhouette shadows
glEnable GL_DEPTH_CLAMP glEnable GL_DEPTH_CLAMP
@@ -213,11 +226,9 @@ lightsToArray xs =
t (V3 a b c, _, _) = [a, b, c, 1] t (V3 a b c, _, _) = [a, b, c, 1]
s (_, d, V3 e f g) = [e, f, g, d] s (_, d, V3 e f g) = [e, f, g, d]
instanceLightMap :: instanceLightMap ::
Configuration -> Configuration ->
RenderData ->
[(Point3, Float, Point3)] -> -- Lights
-- | number of walls -- | number of walls
Int -> Int ->
-- | number of silhoutte lines to draw -- | number of silhoutte lines to draw
@@ -226,8 +237,11 @@ instanceLightMap ::
Int -> Int ->
-- | the texture object giving positions -- | the texture object giving positions
TO -> TO ->
TO ->
[(Point3, Float, Point3)] -> -- Lights
RenderData ->
IO () IO ()
instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do instanceLightMap cfig nWalls nSils nCaps toPos tanormals lightPoints pdata = do
let lcapShad = _shadowCapShader pdata let lcapShad = _shadowCapShader pdata
(xsize, ysize) = getWindowSize cfig (xsize, ysize) = getWindowSize cfig
withArray (lightsToArray lightPoints) $ \ptr -> withArray (lightsToArray lightPoints) $ \ptr ->
@@ -251,12 +265,14 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
1 1
glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboShadow . _1 . unFBO glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboShadow . _1 . unFBO
glDepthMask GL_FALSE glDepthMask GL_FALSE
withArray [0,0,0,0] $ \ptr -> glClearNamedFramebufferfv withArray [0, 0, 0, 0] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboShadow . _1 . unFBO) (pdata ^. fboShadow . _1 . unFBO)
GL_COLOR GL_COLOR
0 0
ptr ptr
with 0 $ \ptr -> glClearNamedFramebufferiv with 0 $ \ptr ->
glClearNamedFramebufferiv
(pdata ^. fboShadow . _1 . unFBO) (pdata ^. fboShadow . _1 . unFBO)
GL_STENCIL GL_STENCIL
0 0
@@ -303,8 +319,7 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
glStencilFunc GL_EQUAL 0 255 glStencilFunc GL_EQUAL 0 255
glUseProgram (pdata ^. shadowLightShader . _1 . shaderUINT) glUseProgram (pdata ^. shadowLightShader . _1 . shaderUINT)
-- bind world position texture -- bind world position texture
bindTO toPos glBindTextureUnit 0 (toPos ^. unTO)
-- glBindVertexArray $ pdata ^. shadowLightShader . shaderVAO' . vaoName
glDrawArrays glDrawArrays
(_unPrimitiveMode $ pdata ^. shadowLightShader . _1 . shaderPrimitive) (_unPrimitiveMode $ pdata ^. shadowLightShader . _1 . shaderPrimitive)
0 0
@@ -313,12 +328,13 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
glDisable GL_STENCIL_TEST glDisable GL_STENCIL_TEST
--draw to the lighting framebuffer here --draw to the lighting framebuffer here
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv withArray [1, 1, 1, 1] $ \ptr ->
glClearNamedFramebufferfv
(pdata ^. fboLighting . _1 . unFBO) (pdata ^. fboLighting . _1 . unFBO)
GL_COLOR GL_COLOR
0 0
ptr ptr
glBindTexture GL_TEXTURE_2D_ARRAY (pdata ^. fboShadow . _2 . _1 . unTO) glBindTextureUnit 0 (pdata ^. fboShadow . _2 . _1 . unTO)
glEnable GL_BLEND glEnable GL_BLEND
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glUseProgram (pdata ^. shadowCombineShader . _1 . shaderUINT) glUseProgram (pdata ^. shadowCombineShader . _1 . shaderUINT)
@@ -339,15 +355,11 @@ pingPongBetween ::
Shader -> Shader ->
IO () IO ()
pingPongBetween (fb1, to1) (fb2, to2) fs = do pingPongBetween (fb1, to1) (fb2, to2) fs = do
--bindFramebuffer Framebuffer $= fb2
glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb2) glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb2)
--textureBinding Texture2D $= Just to1 glBindTextureUnit 0 (_unTO to1)
glBindTexture GL_TEXTURE_2D (_unTO to1)
drawShader fs 4 drawShader fs 4
--bindFramebuffer Framebuffer $= fb1
glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb1) glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb1)
--textureBinding Texture2D $= Just to2 glBindTextureUnit 0 (_unTO to2)
glBindTexture GL_TEXTURE_2D (_unTO to2)
drawShader fs 4 drawShader fs 4
renderLayer :: renderLayer ::
@@ -361,11 +373,6 @@ renderLayer layer shads counts = do
where where
ln = layerNum layer ln = layerNum layer
bindTO :: TO -> IO ()
bindTO t = glBindTexture GL_TEXTURE_2D (_unTO t)
--textureBinding Texture2D $= Just t
bindFBO :: FBO -> IO () bindFBO :: FBO -> IO ()
bindFBO fb = bindFBO fb =
--bindFramebuffer Framebuffer $= fb --bindFramebuffer Framebuffer $= fb
src/Shader.hs
-3
View File
@@ -6,7 +6,6 @@ module Shader (
) where ) where
import Control.Lens import Control.Lens
import Control.Monad
import Control.Monad.Primitive import Control.Monad.Primitive
import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Unboxed.Mutable as UMV
import Foreign import Foreign
@@ -20,7 +19,6 @@ drawShaderLay l countsVector shadIn fs = do
i <- UMV.read countsVector shadIn i <- UMV.read countsVector shadIn
glUseProgram (_shaderUINT $ fst fs) glUseProgram (_shaderUINT $ fst fs)
glBindVertexArray $ fs ^. _1 . shaderVAO . vaoName glBindVertexArray $ fs ^. _1 . shaderVAO . vaoName
zipWithM_ (\ti -> glBindTextureUnit ti . _unTO) [0 ..] (fs ^. _1 . shaderTextures)
glDrawArrays glDrawArrays
(_unPrimitiveMode $ _shaderPrimitive $ fst fs) (_unPrimitiveMode $ _shaderPrimitive $ fst fs)
(fromIntegral $ l * numSubElements) (fromIntegral $ l * numSubElements)
@@ -31,7 +29,6 @@ drawShader :: Shader -> Int -> IO ()
drawShader fs i = do drawShader fs i = do
glUseProgram (_shaderUINT fs) glUseProgram (_shaderUINT fs)
glBindVertexArray $ fs ^. shaderVAO . vaoName glBindVertexArray $ fs ^. shaderVAO . vaoName
zipWithM_ (\ti -> glBindTextureUnit ti . _unTO) [0..] (fs ^. shaderTextures)
glDrawArrays glDrawArrays
(_unPrimitiveMode $ _shaderPrimitive fs) (_unPrimitiveMode $ _shaderPrimitive fs)
0 0
src/Shader/AuxAddition.hs
+48 -116
View File
@@ -1,128 +1,58 @@
module Shader.AuxAddition module Shader.AuxAddition (
( addSamplerTexture2D initTexture2DArray,
, vaddTextureNoFilter initTexture2DArraySquare,
, addTextureArray tilesToLine,
, addBindTextureArray
, initTexture2D
, initTexture2DArray
, tilesToLine
) where ) where
import LensHelp
import Unsafe.Coerce
import Shader.Data
import Data.List.Extra
import Codec.Picture import Codec.Picture
import Data.List.Extra
import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable as VS
import Graphics.GL.Core45
import GLHelp import GLHelp
import Graphics.GL.Core45
-- I am not sure if this assumes that the shader is constructed directly before import Unsafe.Coerce
-- the texture is added...
addSamplerTexture2D :: String -> Shader -> IO Shader
addSamplerTexture2D = addTexture2D 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR
vaddTextureNoFilter :: String -> Shader -> IO Shader
vaddTextureNoFilter = addTexture2D 1 GL_NEAREST GL_NEAREST
addTexture2D
:: GLint -- number of mipmap levels
-> GLenum -- minfilter
-> GLenum -- magfilter
-> String -- path to image
-> Shader -> IO Shader
addTexture2D nlev minfilt magfilt texpath shad = do
Right cmap <- readImage texpath
let texdata = convertRGBA8 cmap
let wtex = fromIntegral $ imageWidth texdata
htex = fromIntegral $ imageHeight texdata
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D
glTextureStorage2D texname nlev GL_RGBA8 wtex htex
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage2D texname 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
return $ shad & shaderTextures .:~ TO texname
-- alloca $ \nameptr -> do
-- glCreateTextures GL_TEXTURE_2D 1 nameptr
-- texname <- peek nameptr
-- glTextureStorage2D texname nlev GL_RGBA8 wtex htex
-- VS.unsafeWith (imageData texdata) $ \ptr -> do
-- glTextureSubImage2D texname 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
-- glGenerateTextureMipmap texname
-- glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
-- glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
-- return $ shad & shadTex' ?~ ShaderTexture
-- {_textureObject = texname }
initTexture2D
:: GLint -- number of mipmap levels
-> GLenum -- minfilter
-> GLenum -- magfilter
-> String -> IO TO
initTexture2D nlev minfilt magfilt fp = do
Right cmap <- readImage fp
let texdata = convertRGBA8 cmap
let wtex = fromIntegral $ imageWidth texdata
htex = fromIntegral $ imageHeight texdata
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D
glTextureStorage2D texname nlev GL_RGBA8 wtex htex
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage2D texname 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
return $ TO texname
-- assumes the texture slices are squares with sides as long as the input is -- assumes the texture slices are squares with sides as long as the input is
-- wide -- wide
initTexture2DArray initTexture2DArraySquare ::
:: GLint -- number of mipmap levels GLuint -> -- binding point
-> GLenum -- minfilter GLint -> -- number of mipmap levels
-> GLenum -- magfilter GLenum -> -- minfilter
-> String -> IO TO GLenum -> -- magfilter
initTexture2DArray nlev minfilt magfilt fp = do String ->
IO ()
initTexture2DArraySquare bindpoint nlev minfilt magfilt fp = do
Right cmap <- readImage fp Right cmap <- readImage fp
let texdata = convertRGBA8 cmap let texdata = convertRGBA8 cmap
let wtex = fromIntegral $ imageWidth texdata let sqside = fromIntegral $ imageWidth texdata
htex = fromIntegral $ imageHeight texdata totalh = fromIntegral $ imageHeight texdata
z = htex `div` wtex d = totalh `div` sqside
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY initTexture2DArrayData bindpoint texdata nlev sqside sqside d minfilt magfilt
glTextureStorage3D texname nlev GL_RGBA8 wtex wtex z
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage3D texname 0 0 0 0 wtex wtex z GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
return $ TO texname
-- | for transforming a 256x256 image containing 64 tiles of 16x16 pixels into initTexture2DArray ::
-- an image that was directly readable by glTexSubImage3D, used the GLuint ->
-- transformation tilesToLine 8 128 on the underlying pixels. String ->
addTextureArray :: String -> (Shader,VBO) -> IO (Shader,VBO) GLsizei ->
addTextureArray texturePath (shad,vbo) = do GLsizei ->
err <- glGetError GLsizei ->
print err GLsizei ->
Right cmap <- readImage texturePath GLenum ->
let texdata = convertRGBA8 cmap GLenum ->
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY IO ()
glTextureStorage3D texname 3 GL_RGBA8 32 32 64 initTexture2DArray bindpoint fp nlev w h d minfilt magfilt = do
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage3D texname 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce GL_LINEAR_MIPMAP_LINEAR)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce GL_LINEAR)
return (shad & shaderTextures .:~ TO texname
, vbo)
addBindTextureArray :: GLuint -> String -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum
-> IO ()
addBindTextureArray bindpoint fp nlev w h d minfilt magfilt = do
Right cmap <- readImage fp Right cmap <- readImage fp
let texdata = convertRGBA8 cmap let texdata = convertRGBA8 cmap
initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt
initTexture2DArrayData :: GLuint -> Image PixelRGBA8 -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum initTexture2DArrayData ::
-> IO () GLuint ->
Image PixelRGBA8 ->
GLsizei ->
GLsizei ->
GLsizei ->
GLsizei ->
GLenum ->
GLenum ->
IO ()
initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt = do initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt = do
texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY
glTextureStorage3D texname nlev GL_RGBA8 w h d glTextureStorage3D texname nlev GL_RGBA8 w h d
@@ -133,9 +63,11 @@ initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt = do
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt) glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
glBindTextureUnit bindpoint texname glBindTextureUnit bindpoint texname
tilesToLine tilesToLine ::
:: Int -- ^ Parameter a -- | Parameter a
-> Int -- ^ Parameter b Int ->
-> [a] -- | Parameter b
-> [a] Int ->
[a] ->
[a]
tilesToLine n w = concat . concat . transpose . chunksOf n . chunksOf w tilesToLine n w = concat . concat . transpose . chunksOf n . chunksOf w
src/Shader/Compile.hs
+40 -59
View File
@@ -2,9 +2,8 @@ module Shader.Compile (
setupVBO, setupVBO,
setupVBOStatic, setupVBOStatic,
makeShaderEBO, makeShaderEBO,
makeShader, makeShaderVBO,
makeShader4, makeShaderUsingVBO,
makeShader4UsingVAO,
makeByteStringShaderUsingVAO, makeByteStringShaderUsingVAO,
makeShaderSized, makeShaderSized,
makeShaderUsingVAO, makeShaderUsingVAO,
@@ -25,13 +24,14 @@ import GLHelp
import Graphics.GL.Core45 import Graphics.GL.Core45
import Shader.Data import Shader.Data
import Shader.Parameters import Shader.Parameters
--import Graphics.GL.Core45 --import Graphics.GL.Core45
{- | {- |
Compiles a full shader found within the shader directory. Compiles a full shader found within the shader directory.
The shader is made up of files begining with the inputted string with extensions .vert, .geom etc. The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
-} -}
makeShader :: makeShaderVBO ::
-- | First part of the name of the shader -- | First part of the name of the shader
String -> String ->
-- | shader types -- | shader types
@@ -40,16 +40,17 @@ makeShader ::
[Int] -> [Int] ->
PrimitiveMode -> PrimitiveMode ->
IO (Shader, VBO) IO (Shader, VBO)
makeShader s shaderlist sizes pm = do makeShaderVBO s shaderlist sizes pm = do
prog <- makeSourcedShader s shaderlist prog <- makeSourcedShader s shaderlist
(vao, vbo) <- setupVAO sizes (vao, vbo) <- setupVAO sizes
return ( Shader return
( Shader
{ _shaderUINT = prog { _shaderUINT = prog
, _shaderVAO = vao , _shaderVAO = vao
, _shaderPrimitive = pm , _shaderPrimitive = pm
, _shaderTextures = mempty
} }
, vbo) , vbo
)
makeShaderEBO :: makeShaderEBO ::
-- | First part of the name of the shader -- | First part of the name of the shader
@@ -68,11 +69,11 @@ makeShaderEBO s shaderlist sizes strd pm vbo = do
vao <- setupVAOvbo sizes strd vbo vao <- setupVAOvbo sizes strd vbo
ebo <- setupEBO vao ebo <- setupEBO vao
return return
( Shader prog pm vao [] ( Shader prog pm vao
, ebo , ebo
) )
makeShader4 :: makeShaderUsingVBO ::
-- | First part of the name of the shader -- | First part of the name of the shader
String -> String ->
-- | shader types -- | shader types
@@ -84,39 +85,16 @@ makeShader4 ::
PrimitiveMode -> PrimitiveMode ->
VBO -> VBO ->
IO Shader IO Shader
makeShader4 s shaderlist sizes strd pm vbo = do makeShaderUsingVBO s shaderlist sizes strd pm vbo = setupVAOvbo sizes strd vbo
prog <- makeSourcedShader s shaderlist >>= makeShaderUsingVAO s shaderlist pm
vao <- setupVAOvbo sizes strd vbo
return $ Shader
{ _shaderUINT = prog
, _shaderVAO = vao
, _shaderPrimitive = pm
, _shaderTextures = mempty
}
makeShader4UsingVAO ::
-- | First part of the name of the shader
String ->
-- | shader types
[GLenum] ->
PrimitiveMode ->
VAO ->
IO Shader
makeShader4UsingVAO s shaderlist pm vao = do
prog <- makeSourcedShader s shaderlist
return $ Shader
{ _shaderUINT = prog
, _shaderVAO = vao
, _shaderPrimitive = pm
, _shaderTextures = []
}
setupVBO :: Int -> IO VBO setupVBO :: Int -> IO VBO
setupVBO vertexsize = do setupVBO vertexsize = do
vboname <- mglCreate glCreateBuffers vboname <- mglCreate glCreateBuffers
thePtr <- mallocArray (vertexsize * numDrawableElements) thePtr <- mallocArray (vertexsize * numDrawableElements)
-- Allocate space -- Allocate space
glNamedBufferData vboname glNamedBufferData
vboname
(fromIntegral $ floatSize * numDrawableElements * vertexsize) (fromIntegral $ floatSize * numDrawableElements * vertexsize)
nullPtr nullPtr
GL_STREAM_DRAW GL_STREAM_DRAW
@@ -127,7 +105,8 @@ setupVBOStatic vertexsize = do
vboname <- mglCreate glCreateBuffers vboname <- mglCreate glCreateBuffers
thePtr <- mallocArray (vertexsize * numDrawableElements) thePtr <- mallocArray (vertexsize * numDrawableElements)
-- Allocate space -- Allocate space
glNamedBufferData vboname glNamedBufferData
vboname
(fromIntegral $ floatSize * numDrawableElements * vertexsize) (fromIntegral $ floatSize * numDrawableElements * vertexsize)
nullPtr nullPtr
GL_STATIC_DRAW GL_STATIC_DRAW
@@ -143,12 +122,11 @@ makeByteStringShaderUsingVAO ::
IO Shader IO Shader
makeByteStringShaderUsingVAO s shaderlist pm vao = do makeByteStringShaderUsingVAO s shaderlist pm vao = do
prog <- makeShaderProgram s shaderlist prog <- makeShaderProgram s shaderlist
return $ return
Shader Shader
{ _shaderUINT = prog { _shaderUINT = prog
, _shaderVAO = vao , _shaderVAO = vao
, _shaderPrimitive = pm , _shaderPrimitive = pm
, _shaderTextures = mempty
} }
-- | Takes the VAO from elsewhere -- | Takes the VAO from elsewhere
@@ -162,12 +140,11 @@ makeShaderUsingVAO ::
IO Shader IO Shader
makeShaderUsingVAO s shaderlist pm theVAO = do makeShaderUsingVAO s shaderlist pm theVAO = do
prog <- makeSourcedShader s shaderlist prog <- makeSourcedShader s shaderlist
return $ return
Shader Shader
{ _shaderUINT = prog { _shaderUINT = prog
, _shaderVAO = theVAO , _shaderVAO = theVAO
, _shaderPrimitive = pm , _shaderPrimitive = pm
, _shaderTextures = mempty
} }
{- | {- |
@@ -188,13 +165,14 @@ makeShaderSized ::
makeShaderSized s shaderlist sizes ndraw pm = do makeShaderSized s shaderlist sizes ndraw pm = do
prog <- makeSourcedShader s shaderlist prog <- makeSourcedShader s shaderlist
(vao, vbo) <- setupVAOSized ndraw sizes (vao, vbo) <- setupVAOSized ndraw sizes
return ( Shader return
( Shader
{ _shaderUINT = prog { _shaderUINT = prog
, _shaderVAO = vao , _shaderVAO = vao
, _shaderPrimitive = pm , _shaderPrimitive = pm
, _shaderTextures = mempty
} }
, vbo) , vbo
)
{- | Compile shader and get its uniform locations. {- | Compile shader and get its uniform locations.
supposes the shader code is in the shader folder, with the string names supposes the shader code is in the shader folder, with the string names
@@ -202,14 +180,14 @@ makeShaderSized s shaderlist sizes ndraw pm = do
-} -}
makeSourcedShader :: String -> [GLenum] -> IO GLuint makeSourcedShader :: String -> [GLenum] -> IO GLuint
makeSourcedShader s sts = do makeSourcedShader s sts = do
sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt' st) sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
makeShaderProgram s $ zip sts sources makeShaderProgram s $ zip sts sources
shaderTypeExt' :: GLenum -> String shaderTypeExt :: GLenum -> String
shaderTypeExt' GL_VERTEX_SHADER = ".vert" shaderTypeExt GL_VERTEX_SHADER = ".vert"
shaderTypeExt' GL_GEOMETRY_SHADER = ".geom" shaderTypeExt GL_GEOMETRY_SHADER = ".geom"
shaderTypeExt' GL_FRAGMENT_SHADER = ".frag" shaderTypeExt GL_FRAGMENT_SHADER = ".frag"
shaderTypeExt' _ = undefined shaderTypeExt _ = undefined
-- I think that this requires that the correct shader program is bound? -- I think that this requires that the correct shader program is bound?
setupVAO :: [Int] -> IO (VAO, VBO) setupVAO :: [Int] -> IO (VAO, VBO)
@@ -220,17 +198,18 @@ setupVAOvbo' sizes strd vbo = do
vaoname <- mglCreate glCreateVertexArrays vaoname <- mglCreate glCreateVertexArrays
glBindVertexArray vaoname glBindVertexArray vaoname
setupVertexAttribs' vbo vaoname sizes strd setupVertexAttribs' vbo vaoname sizes strd
return $ VAO return $
VAO
{ _vaoName = vaoname { _vaoName = vaoname
} }
setupVAOvbo :: [Int] -> Int -> VBO -> IO VAO setupVAOvbo :: [Int] -> Int -> VBO -> IO VAO
setupVAOvbo sizes strd vbo = do setupVAOvbo sizes strd vbo = do
vaoname <- mglCreate glCreateVertexArrays vaoname <- mglCreate glCreateVertexArrays
glBindVertexArray vaoname glBindVertexArray vaoname
setupVertexAttribs vbo vaoname sizes strd setupVertexAttribs vbo vaoname sizes strd
return $ VAO return $
VAO
{ _vaoName = vaoname { _vaoName = vaoname
} }
@@ -251,10 +230,12 @@ setupVAOSized ndraw sizes = do
vaoname <- mglCreate glCreateVertexArrays vaoname <- mglCreate glCreateVertexArrays
glBindVertexArray vaoname glBindVertexArray vaoname
theVBO <- setupVBOSized ndraw vaoname sizes theVBO <- setupVBOSized ndraw vaoname sizes
return ( VAO return
( VAO
{ _vaoName = vaoname { _vaoName = vaoname
} }
, theVBO) , theVBO
)
setupVBOSized :: Int -> GLuint -> [Int] -> IO VBO setupVBOSized :: Int -> GLuint -> [Int] -> IO VBO
setupVBOSized ndraw vao sizes = do setupVBOSized ndraw vao sizes = do
@@ -266,7 +247,8 @@ setupVBOSized ndraw vao sizes = do
setupVertexAttribPointer vao loc siz off setupVertexAttribPointer vao loc siz off
thePtr <- mallocArray (strd * ndraw) thePtr <- mallocArray (strd * ndraw)
-- Allocate space -- Allocate space
glNamedBufferData vboname glNamedBufferData
vboname
(fromIntegral $ floatSize * ndraw * strd) (fromIntegral $ floatSize * ndraw * strd)
nullPtr nullPtr
GL_STREAM_DRAW GL_STREAM_DRAW
@@ -356,7 +338,7 @@ compileAndCheckShader str (theShaderType, sourceCode) = do
setShaderSource theShader sourceCode setShaderSource theShader sourceCode
glCompileShader theShader glCompileShader theShader
checkErrorGL checkErrorGL
(str ++ shaderTypeExt' theShaderType) (str ++ shaderTypeExt theShaderType)
glGetShaderiv glGetShaderiv
glGetShaderInfoLog glGetShaderInfoLog
theShader theShader
@@ -375,4 +357,3 @@ withByteString :: Num t => BS.ByteString -> (Ptr b -> t -> IO a) -> IO a
withByteString bs act = withByteString bs act =
BU.unsafeUseAsCStringLen bs $ \(ptr, size) -> BU.unsafeUseAsCStringLen bs $ \(ptr, size) ->
act (castPtr ptr) (fromIntegral size) act (castPtr ptr) (fromIntegral size)
src/Shader/Data.hs
-2
View File
@@ -16,7 +16,6 @@ module Shader.Data (
shaderUINT, shaderUINT,
shaderPrimitive, shaderPrimitive,
shaderVAO, shaderVAO,
shaderTextures,
textureObject, textureObject,
vboName, vboName,
vboPtr, vboPtr,
@@ -51,7 +50,6 @@ data Shader = Shader
{ _shaderUINT :: GLuint -- should be shaderID { _shaderUINT :: GLuint -- should be shaderID
, _shaderPrimitive :: PrimitiveMode , _shaderPrimitive :: PrimitiveMode
, _shaderVAO :: VAO , _shaderVAO :: VAO
, _shaderTextures :: [TO]
} }
newtype FBO = FBO {_unFBO :: GLuint} newtype FBO = FBO {_unFBO :: GLuint}
src/Shader/Poke.hs
+4 -4
View File
@@ -10,7 +10,7 @@ module Shader.Poke (
import Geometry.Vector import Geometry.Vector
import Dodge.Data.Wall import Dodge.Data.Wall
import Shader.Poke.Triangulate import Geometry.Triangulate
import Control.Monad.Primitive import Control.Monad.Primitive
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Data.Vector.Fusion.Stream.Monadic as VFSM import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
@@ -257,7 +257,7 @@ pokeIndex nv eiptr ni ioff = do
memoFlatIndices :: V.Vector (UV.Vector Int) memoFlatIndices :: V.Vector (UV.Vector Int)
memoFlatIndices = memoFlatIndices =
V.generate 10 $ V.generate 10 $
UV.fromList . concatMap triangulate . boxSurfaces' . (+ 3) UV.fromList . concatMap polyToTris . boxSurfaces' . (+ 3)
memoTopPrismIndices :: V.Vector (UV.Vector Int) memoTopPrismIndices :: V.Vector (UV.Vector Int)
{-# INLINE memoTopPrismIndices #-} {-# INLINE memoTopPrismIndices #-}
@@ -313,8 +313,8 @@ boxEdgeIndices n = concatMap f [0 .. n -1]
cylinderIndices :: Int -> [Int] cylinderIndices :: Int -> [Int]
cylinderIndices n = cylinderIndices n =
cylinderRoundIndices n cylinderRoundIndices n
++ triangulate [2 * n, 2 * n + 2 .. 4 * n - 1] ++ polyToTris [2 * n, 2 * n + 2 .. 4 * n - 1]
++ triangulate [2 * n + 1, 2 * n + 3 .. 4 * n - 1] ++ polyToTris [2 * n + 1, 2 * n + 3 .. 4 * n - 1]
cylinderRoundIndices :: Int -> [Int] cylinderRoundIndices :: Int -> [Int]
cylinderRoundIndices n = cylinderRoundIndices n =
src/Shader/Poke/Floor.hs
+5 -6
View File
@@ -1,17 +1,16 @@
module Shader.Poke.Floor module Shader.Poke.Floor (
( pokeTile pokeTile,
) where ) where
import Geometry
import Shader.Poke.Triangulate
import Control.Monad import Control.Monad
import Tile
import Data.Tile import Data.Tile
import Foreign import Foreign
import Geometry
import Tile
pokeTile :: Ptr Float -> Int -> Tile -> IO Int pokeTile :: Ptr Float -> Int -> Tile -> IO Int
pokeTile ptr i t@Tile{_tilePoly = ps} = do pokeTile ptr i t@Tile{_tilePoly = ps} = do
foldM (pokeTileVerx ttan (_tileArrayZ t) ptr) i $ triangulate $ zip ps (tileTexCoords t) foldM (pokeTileVerx ttan (_tileArrayZ t) ptr) i $ polyToTris $ zip ps (tileTexCoords t)
where where
ttan = _tileTangentPos t - _tileZero t ttan = _tileTangentPos t - _tileZero t
src/Shader/Poke/Triangulate.hs
-15
View File
@@ -1,15 +0,0 @@
module Shader.Poke.Triangulate where
import qualified Data.Vector as V
triangulate :: [a] -> [a]
{-# INLINE triangulate #-}
triangulate is = V.toList . V.backpermute (V.fromList is) . V.fromList $ triangulateIndices (length is)
triangulateIndices :: Int -> [Int]
{-# INLINE triangulateIndices #-}
triangulateIndices i = concatMap f [0 .. i -3]
where
f x
| even x = [0, x + 1, x + 2]
| otherwise = [0, x + 2, x + 1]
src/ShapePicture.hs
+5 -5
View File
@@ -2,7 +2,7 @@
module ShapePicture module ShapePicture
( module ShapePicture.Data ( module ShapePicture.Data
, translateSP , translateSP
, translateSPf , translateSPxy
, translateSPz , translateSPz
, rotateSP , rotateSP
, noPic , noPic
@@ -42,13 +42,13 @@ overPosSP :: (Point3 -> Point3) -> SPic -> SPic
{-# INLINE overPosSP #-} {-# INLINE overPosSP #-}
overPosSP f = bimap (overPosSH f) (picMap $ overPos f) overPosSP f = bimap (overPosSH f) (picMap $ overPos f)
translateSPf :: Float -> Float -> SPic -> SPic translateSPxy :: Float -> Float -> SPic -> SPic
{-# INLINE translateSPf #-} {-# INLINE translateSPxy #-}
translateSPf x y = bimap (translateSH (V3 x y 0)) (translate x y) translateSPxy x y = translateSP (V3 x y 0)
translateSPz :: Float -> SPic -> SPic translateSPz :: Float -> SPic -> SPic
{-# INLINE translateSPz #-} {-# INLINE translateSPz #-}
translateSPz z = bimap (translateSH (V3 0 0 z)) (translate3 (V3 0 0 z)) translateSPz z = translateSP (V3 0 0 z)
translateSP :: Point3 -> SPic -> SPic translateSP :: Point3 -> SPic -> SPic
{-# INLINE translateSP #-} {-# INLINE translateSP #-}