From 1abfaa3cd012108d1908e48c35eb56c758d2a369 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 23 Mar 2023 21:17:24 +0000 Subject: [PATCH] Work on textures and lighting --- bench/Bench.hs | 14 +- package.yaml | 2 +- shader/texture/bloomBlur.frag | 2 + shader/texture/simple.frag | 2 +- src/Data/Preload/Render.hs | 4 - src/Dodge/Creature/HandPos.hs | 60 ++--- src/Dodge/Creature/Picture.hs | 2 +- src/Dodge/Data/Config.hs | 7 +- src/Dodge/HeldUse.hs | 2 +- src/Dodge/Projectile/Draw.hs | 2 +- src/Dodge/Prop/Draw.hs | 2 +- src/Dodge/Render.hs | 31 +-- src/Dodge/Render/ShapePicture.hs | 35 ++- src/Framebuffer/Update.hs | 3 +- src/Geometry.hs | 415 +++++++++++++++++-------------- src/Preload/Render.hs | 31 +-- src/Render.hs | 373 +++++++++++++-------------- src/Shader.hs | 3 - src/Shader/AuxAddition.hs | 166 ++++--------- src/Shader/Compile.hs | 139 +++++------ src/Shader/Data.hs | 2 - src/Shader/Poke.hs | 8 +- src/Shader/Poke/Floor.hs | 21 +- src/Shader/Poke/Triangulate.hs | 15 -- src/ShapePicture.hs | 10 +- 25 files changed, 641 insertions(+), 710 deletions(-) delete mode 100644 src/Shader/Poke/Triangulate.hs diff --git a/bench/Bench.hs b/bench/Bench.hs index fcf0709d7..13a5ac902 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,6 +1,7 @@ import Criterion.Main -import Dodge.RandomHelp +import RandomHelp +import Shader.Poke.Triangulate import Geometry import Dodge.Creature.Inanimate @@ -13,24 +14,25 @@ import Data.List (zip4) main :: IO () 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)) defaultMain [ bgroup "polyToTris tests" - [ bench "polyToTris 5" $ nf polyToTris ps1 + [ bench "polyToTris 5" $ nf ( polyToTris) ps1 , bench "polyToTris 10" $ nf polyToTris ps2 , bench "polyToTris 50" $ nf polyToTris ps3 - , bench "polyToTris 500" $ nf polyToTris ps4 + --, bench "polyToTris 500" $ nf polyToTris ps4 ] , bgroup "polyToTriFold tests" [ bench "polyToTriFold 5" $ nf polyToTris'' ps1 , bench "polyToTriFold 10" $ nf polyToTris'' ps2 , 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 i = getStdGen <&> evalState (replicateM i $ randInCirc 500) diff --git a/package.yaml b/package.yaml index 5429ecffd..29115cdac 100644 --- a/package.yaml +++ b/package.yaml @@ -116,7 +116,7 @@ benchmarks: - -fno-liberate-case - -fno-state-hack - -funfolding-use-threshold1000 - - -funfolding-keeness-factor1000 + # - -funfolding-keeness-factor1000 - -fllvm #- -optlo-O3 main: Bench.hs diff --git a/shader/texture/bloomBlur.frag b/shader/texture/bloomBlur.frag index f50d14f71..dd05ea52a 100644 --- a/shader/texture/bloomBlur.frag +++ b/shader/texture/bloomBlur.frag @@ -33,6 +33,8 @@ void main() { 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 = max(texture(screenTexture,vTexPos), sumFive / 5); //fColor = vec4 ( (sumFive / 5).rgb, max((sumFive/5.0).a,texture(screenTexture,vTexPos).a) ); diff --git a/shader/texture/simple.frag b/shader/texture/simple.frag index 2ed3455a4..342560976 100644 --- a/shader/texture/simple.frag +++ b/shader/texture/simple.frag @@ -2,7 +2,7 @@ in vec2 vTexPos; out vec4 fColor; -uniform sampler2D screenTexture; +layout (binding = 0) uniform sampler2D screenTexture; void main() { diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index 580cc798a..1cafed059 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -21,8 +21,6 @@ data RenderData = RenderData , _shadowWallShader :: Shader , _shadowLightShader :: (Shader,VBO) , _shadowCombineShader :: (Shader,VBO) - --, _positionalBlankShader :: (Shader,VBO) - , _wallBlankShader :: Shader , _windowShader :: Shader , _fullscreenShader :: Shader , _bloomBlurShader :: Shader @@ -53,8 +51,6 @@ data RenderData = RenderData , _vboShapes :: VBO , _floorVBO :: VBO , _floorShader :: Shader - , _texaNormalMaps :: TO - , _texaDiffuse :: TO , _wallVBO :: VBO , _wallShader :: Shader , _cloudVBO :: VBO diff --git a/src/Dodge/Creature/HandPos.hs b/src/Dodge/Creature/HandPos.hs index 1de12575e..67a5ac107 100644 --- a/src/Dodge/Creature/HandPos.hs +++ b/src/Dodge/Creature/HandPos.hs @@ -49,12 +49,12 @@ translateToRightHand cr = translateToRightHand' cr -- . mirrorSPxz translateToRightHand' :: Creature -> SPic -> SPic translateToRightHand' cr - | oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1) - | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) - | twoFlat cr = waistSP . translateSPf 4 (-8) + | oneH cr = shoulderSP . translateSPxy 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1) + | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 4 (-10) + | twoFlat cr = waistSP . translateSPxy 4 (-8) | otherwise = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) - _ -> waistSP . translateSPf 0 (- off) + Just (Walking sa LeftForward) -> waistSP . translateSPxy (- f sa) (- off) + _ -> waistSP . translateSPxy 0 (- off) where off = 8 sLen = _strideLength $ _crStance cr @@ -65,12 +65,12 @@ translateToRightWrist cr = translateToRightWrist' cr -- . mirrorSPxz translateToRightWrist' :: Creature -> SPic -> SPic translateToRightWrist' cr - | oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1) - | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) . offTrans - | twoFlat cr = waistSP . translateSPf 4 (-8) . offTrans + | oneH cr = shoulderSP . translateSPxy 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1) + | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 4 (-10) . offTrans + | twoFlat cr = waistSP . translateSPxy 4 (-8) . offTrans | otherwise = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) . offTrans - _ -> waistSP . translateSPf 0 (- off) . offTrans + Just (Walking sa LeftForward) -> waistSP . translateSPxy (- f sa) (- off) . offTrans + _ -> waistSP . translateSPxy 0 (- off) . offTrans where offTrans = translateSP (V3 0 4 (-4)) off = 8 @@ -92,12 +92,12 @@ translatePointToLeftHand cr translateToLeftHand :: Creature -> SPic -> SPic translateToLeftHand cr - | oneH cr = waistSP . rotateSP 0.4 . translateSPf 0 off - | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 - | twoFlat cr = waistSP . translateSPf 4 8 + | oneH cr = waistSP . rotateSP 0.4 . translateSPxy 0 off + | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 12 4 + | twoFlat cr = waistSP . translateSPxy 4 8 | otherwise = case cr ^? crStance . carriage of - Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off - _ -> waistSP . translateSPf 0 off + Just (Walking sa RightForward) -> waistSP . translateSPxy (- f sa) off + _ -> waistSP . translateSPxy 0 off where off = 8 sLen = _strideLength $ _crStance cr @@ -105,12 +105,12 @@ translateToLeftHand cr translateToLeftWrist :: Creature -> SPic -> SPic translateToLeftWrist cr - | oneH cr = waistSP . rotateSP 0.4 . translateSPf 0 off . offTrans - | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 . offTrans - | twoFlat cr = waistSP . translateSPf 4 8 . offTrans + | oneH cr = waistSP . rotateSP 0.4 . translateSPxy 0 off . offTrans + | twists cr = shoulderSP . translateSPxy 0 5 . rotateSP (-1) . translateSPxy 12 4 . offTrans + | twoFlat cr = waistSP . translateSPxy 4 8 . offTrans | otherwise = case cr ^? crStance . carriage of - Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off . offTrans - _ -> waistSP . translateSPf 0 off . offTrans + Just (Walking sa RightForward) -> waistSP . translateSPxy (- f sa) off . offTrans + _ -> waistSP . translateSPxy 0 off . offTrans where offTrans = translateSP (V3 0 4 (-4)) off = 8 @@ -120,9 +120,9 @@ translateToLeftWrist cr translateToLeftLeg :: Creature -> SPic -> SPic translateToLeftLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> translateSPf (f sa) off - Just (Walking sa RightForward) -> translateSPf (- f sa) off - _ -> translateSPf 0 off + Just (Walking sa LeftForward) -> translateSPxy (f sa) off + Just (Walking sa RightForward) -> translateSPxy (- f sa) off + _ -> translateSPxy 0 off where off = 5 sLen = _strideLength $ _crStance cr @@ -131,9 +131,9 @@ translateToLeftLeg cr = translateToRightLeg :: Creature -> SPic -> SPic translateToRightLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> translateSPf (- f sa) (- off) - Just (Walking sa RightForward) -> translateSPf (f sa) (- off) - _ -> translateSPf 0 (- off) + Just (Walking sa LeftForward) -> translateSPxy (- f sa) (- off) + Just (Walking sa RightForward) -> translateSPxy (f sa) (- off) + _ -> translateSPxy 0 (- off) where off = 5 sLen = _strideLength $ _crStance cr @@ -142,12 +142,12 @@ translateToRightLeg cr = translateToHead :: Creature -> SPic -> SPic translateToHead 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 | oneH cr = - translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0 + translateSPz 20 . rotateSP 0.5 . translateSPxy 2.5 0 . rotateSP (negate 0.5) - | otherwise = translateSPz 20 . translateSPf 2.5 0 + | otherwise = translateSPz 20 . translateSPxy 2.5 0 translatePointToHead :: Creature -> Point3 -> Point3 translatePointToHead cr @@ -162,7 +162,7 @@ translatePointToHead cr translateToChest :: Creature -> SPic -> SPic translateToChest cr | oneH cr = rotateSP 0.5 - -- | twists cr = translateSPf 0 5 . rotateSP (-1) + -- | twists cr = translateSPxy 0 5 . rotateSP (-1) | twists cr = rotateSP (-1) | otherwise = id diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 79881054a..2b34fe00a 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -23,7 +23,7 @@ import qualified Quaternion as Q import ShapePicture 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) --testShape :: Shape diff --git a/src/Dodge/Data/Config.hs b/src/Dodge/Data/Config.hs index fb21af636..69ff3e7e3 100644 --- a/src/Dodge/Data/Config.hs +++ b/src/Dodge/Data/Config.hs @@ -39,7 +39,7 @@ data Configuration = Configuration , _volume_sound :: Float , _volume_music :: Float , _graphics_cloud_shadows :: Bool - , _graphics_object_shadows :: ObjectShadows + , _graphics_object_shadows :: ShadowRendering , _graphics_resolution_factor :: ResFactor , _graphics_num_shadow_casters :: NumShadowCasters , _windowX :: Float @@ -84,7 +84,8 @@ data DebugBool data ResFactor = FullRes | HalfRes | QuarterRes deriving (Show, Eq, Ord, Enum, Bounded) -data ObjectShadows = GeoObjShads +data ShadowRendering + = GeoObjShads | InstancingShads | NoObjShads | NoShadows @@ -125,7 +126,7 @@ debugOn db = S.member db . _debug_booleans makeLenses ''Configuration deriveJSON defaultOptions ''NumShadowCasters deriveJSON defaultOptions ''ResFactor -deriveJSON defaultOptions ''ObjectShadows +deriveJSON defaultOptions ''ShadowRendering deriveJSON defaultOptions ''RoomClipping deriveJSON defaultOptions ''DebugBool deriveJSON defaultOptions ''Configuration diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 40705bf05..88194c7ce 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -353,7 +353,7 @@ useMod hm = case hm of moddelay x = itUse . heldConsumption . laAmmoType . amBullet . buDelayFraction .~ x modcrpos x cr = cr & crDir %~ tweenAngles x (_crOldDir cr) - & crPos %~ tweenPoints x (_crOldPos cr) + & crPos %~ alongSegBy x (_crOldPos cr) mcUseHeld :: HeldItemType -> Item -> Machine -> World -> World mcUseHeld hit = case hit of diff --git a/src/Dodge/Projectile/Draw.hs b/src/Dodge/Projectile/Draw.hs index c97431a3a..ee331b821 100644 --- a/src/Dodge/Projectile/Draw.hs +++ b/src/Dodge/Projectile/Draw.hs @@ -34,7 +34,7 @@ drawRemoteShell pj | t > (-99) = green | otherwise = red 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 col = diff --git a/src/Dodge/Prop/Draw.hs b/src/Dodge/Prop/Draw.hs index 35ecbcba9..0b6b7a9d2 100644 --- a/src/Dodge/Prop/Draw.hs +++ b/src/Dodge/Prop/Draw.hs @@ -22,7 +22,7 @@ drawProp pd = case pd of PropDrawToggle pd' -> propDrawToggle pd' PropDrawGib x -> noPic . drawGib x 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 x pr = flesh <> skin diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index e608e0891..b414c2b19 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -5,6 +5,7 @@ module Dodge.Render ( --import qualified Data.Vector as V +import Dodge.DownscaleSize import Data.List (sortOn) import Shader.Poke.Cloud import GLHelp @@ -187,14 +188,14 @@ doDrawing' win pdata u = do --draw lightmap into its own buffer createLightMap cfig - pdata - lightPoints + (u ^. uvConfig . graphics_object_shadows) nWalls nSilIndices nIndices - (u ^. uvConfig . graphics_object_shadows) (pdata ^. fboBase . _2 . _2) (pdata ^. fboBase . _2 . _3) + lightPoints + pdata glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE --apply lightmap to base buffer glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase . _1 . unFBO) @@ -221,13 +222,14 @@ doDrawing' win pdata u = do glDepthMask GL_TRUE renderLayer BloomLayer shadV layerCounts --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))) glDepthFunc GL_ALWAYS glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO) glDisable GL_BLEND 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 setViewportSize (round winx `div` resFact) (round winy `div` resFact) --draw clouds onto cloud buffer @@ -302,21 +304,21 @@ doDrawing' win pdata u = do glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) createLightMap cfig - pdata - lightPoints + (_graphics_object_shadows $ _uvConfig u) nWalls nSilIndices nIndices - (_graphics_object_shadows $ _uvConfig u) (pdata ^. fboPos . _2) (pdata ^. fboCloud . _2 . _3) + lightPoints + pdata glInvalidateBufferData (pdata ^. vboShapes . vboName) --apply lightmap to cloud buffer glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) glDepthMask GL_FALSE withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr glDepthFunc GL_ALWAYS - glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboLighting pdata) + glBindTextureUnit 0 (_unTO . snd $ _fboLighting pdata) glEnable GL_BLEND glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE drawShader (_fullscreenShader pdata) 4 @@ -326,20 +328,21 @@ doDrawing' win pdata u = do --Draw blurred bloom onto base buffer glEnable GL_BLEND glBlendFunc GL_SRC_ALPHA GL_ONE - glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboHalf1 pdata) + glBindTextureUnit 0 (_unTO . snd $ _fboHalf1 pdata) drawShader (_fullscreenShader pdata) 4 glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA --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 --set viewport for radial distortion setViewportSize (round winx) (round winy) glDepthFunc GL_ALWAYS glBlendFunc GL_ONE GL_ZERO -- perform any radial distortion + -- this is hideous case w ^. cWorld . lWorld . distortions of [] -> do - bindTO $ pdata ^. fboBase . _2 . _1 + glBindTextureUnit 0 $ pdata ^. fboBase . _2 . _1 . unTO glBindFramebuffer GL_FRAMEBUFFER 0 drawShader (_fullscreenShader pdata) 4 rds -> do @@ -352,10 +355,8 @@ doDrawing' win pdata u = do take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata])) ++ [FBO 0] toList = (pdata ^. fboBase . _2 . _1) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata]) - bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList) - glActiveTexture GL_TEXTURE1 + bindings = zipWith (>>) (map bindFBO fboList) (map (glBindTextureUnit 1 . _unTO) toList) zipWithM_ (>>) bindings $ map bindDrawDist rds - glActiveTexture GL_TEXTURE1 glDepthFunc GL_ALWAYS glEnable GL_BLEND glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 6151aaacc..ccee90f22 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -2,8 +2,6 @@ module Dodge.Render.ShapePicture ( worldSPic, ) where -import Dodge.Render.Picture -import Dodge.Data.Universe import Control.Lens import Control.Monad (guard) import Data.Foldable @@ -14,6 +12,7 @@ import qualified Data.Set as Set import Dodge.Base import Dodge.Creature.Picture import Dodge.Creature.Picture.Awareness +import Dodge.Data.Universe import Dodge.Debug.Picture import Dodge.Draw import Dodge.Flare @@ -25,6 +24,7 @@ import Dodge.RadarBlip import Dodge.Render.InfoBox import Dodge.Render.Label import Dodge.Render.List +import Dodge.Render.Picture import Dodge.ShortShow import Dodge.SoundLogic.LoadSound import Dodge.Viewpoints @@ -36,7 +36,7 @@ import Geometry.ConvexPoly import qualified IntMapHelp as IM import Padding import Picture -import Polyhedra +import Shape import ShapePicture import ShortShow import Sound.Data @@ -108,21 +108,14 @@ drawCreature cr = case _crType cr of ] ) cr - Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr + Lampoid{_lampHeight = h} -> uncurryV translateSPxy (_crPos cr) $ lampCrSPic h NonDrawnCreature -> mempty -lampCrPic :: Float -> Picture -lampCrPic h = - pictures - [ 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 +lampCrSPic :: Float -> SPic +lampCrSPic h = + ( colorSH blue . upperBox h $ rectWH 5 5 + , setLayer BloomLayer (setDepth h . color white $ circleSolid 3) + ) picAtCrPos1 :: Picture -> Creature -> SPic --{-# 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 fpos fdir fdraw x = - uncurryV translateSPf (fpos x) + uncurryV translateSPxy (fpos x) . rotateSP (fdir x) $ fdraw x x shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic shiftDraw' fpos fdir fdraw x = - uncurryV translateSPf (fpos x) + uncurryV translateSPxy (fpos x) . rotateSP (fdir x) $ fdraw x @@ -366,17 +359,17 @@ ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) floorItemSPic :: FloorItem -> SPic floorItemSPic flit = - uncurryV translateSPf (_flItPos flit) $ + uncurryV translateSPxy (_flItPos flit) $ rotateSP (_flItRot flit) (itemSPic (_flIt flit)) btSPic :: Button -> SPic btSPic bt = - uncurryV translateSPf (_btPos bt) $ + uncurryV translateSPxy (_btPos bt) $ rotateSP (_btRot bt) (drawButton (_btPict bt) bt) mcSPic :: Machine -> SPic mcSPic mc = - uncurryV translateSPf (_mcPos mc) $ + uncurryV translateSPxy (_mcPos mc) $ rotateSP (_mcDir mc) (drawMachine mc) soundPic :: Configuration -> World -> Sound -> Picture diff --git a/src/Framebuffer/Update.hs b/src/Framebuffer/Update.hs index 3eee6d6dc..4ff6196d8 100644 --- a/src/Framebuffer/Update.hs +++ b/src/Framebuffer/Update.hs @@ -7,6 +7,7 @@ module Framebuffer.Update ( sizeFBOs, ) where +import Dodge.DownscaleSize import Shader.Data import Framebuffer.Check import Control.Lens @@ -45,7 +46,7 @@ sizeFBOs xsize ysize xfull yfull rdata = do [fbo2, fbo3] rdata4 <- 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''' [fboHalf1, fboHalf2, fboHalf3] newShadowFBO <- resizeShadowFBO (rdata ^. fboShadow) xsize ysize diff --git a/src/Geometry.hs b/src/Geometry.hs index 5ccf21071..4711c0366 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -1,345 +1,386 @@ {-# LANGUAGE BangPatterns #-} -{-| + +{- | Module : Geometry Description : Geometry helpers This module provides geometry functions that manipulate pairs of floats. -Conventions: +Conventions: 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. -} -module Geometry - ( module Geometry - , module Geometry.Data - , module Geometry.Intersect - , module Geometry.Bezier - , module Geometry.Vector - , module Geometry.Vector3D - , module Geometry.LHS - , module Geometry.Polygon - , loopPairs - ) 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 +module Geometry ( + module Geometry, + module Geometry.Data, + module Geometry.Intersect, + module Geometry.Bezier, + module Geometry.Vector, + module Geometry.Vector3D, + module Geometry.LHS, + module Geometry.Polygon, + module Geometry.Triangulate, + loopPairs, +) where 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.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 !x !a !b = a +.+ y *.* normalizeV (b -.- a) where y = min x $ dist a b -tweenPoints :: Float -> Point2 -> Point2 -> Point2 -tweenPoints = alongSegBy -- | Debug version of 'pointInPolygon'. errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool -errorPointInPolygon !i !p xs +errorPointInPolygon !i !p xs | length xs == 1 = error "one point polygon" | length xs == 2 = error "two point polygon" | nub xs == xs = pointInPolygon p xs - | otherwise = error $ "errorPointInPolygon "++ show i + | otherwise = error $ "errorPointInPolygon " ++ show i + -- | Debug version of 'normalizeV'. 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 + -- | Debug version of 'angleVV'. 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 _ !p !p' = angleVV p p' +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' + -- | Debug version of 'isLHS'. errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool -errorIsLHS !i !x !y - | x == y = error $ "problem with function: errorIsLHS " ++show i +errorIsLHS !i !x !y + | x == y = error $ "problem with function: errorIsLHS " ++ show i | otherwise = isLHS x y + -- | Debug version of 'closestPointOnLine' errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2 -errorClosestPointOnLine !i !x !y - | x == y = error $ "problem with function: errorClosestPointOnLine " ++show i +errorClosestPointOnLine !i !x !y + | x == y = error $ "problem with function: errorClosestPointOnLine " ++ show i | otherwise = closestPointOnLine x y + -- | Debug version of 'closestPointOnLineParam' errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float -errorClosestPointOnLineParam _ !x !y !z - | x == y = dist x z +errorClosestPointOnLineParam _ !x !y !z + | x == y = dist x z | otherwise = closestPointOnLineParam x y z -- | Return midpoint between two points. midPoint :: Point2 -> Point2 -> Point2 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. --- Returns False if the circle center is beyond the endpoints of the --- segment. + +{- | Test whether a circle is on a segment by intersecting a new normal segment through the + center of the circle with the segment itself. + Returns False if the circle center is beyond the endpoints of the + segment. +-} circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool {-# INLINE circOnSegNoEndpoints #-} circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) - where - 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. --- Perhaps a better order of arguments. -circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool -{-# INLINE circOnSeg #-} -circOnSeg !c !rad !p1 !p2 = magV (p1 -.- c) <= rad - || magV (p2 -.- c) <= rad - || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) - where + where thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) --- | Test whether a segment intersects a circle 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 + the distance to the endpoints of the segment. + Perhaps a better order of arguments. +-} +circOnSeg :: Point2 -> Float -> Point2 -> Point2 -> Bool +{-# INLINE circOnSeg #-} +circOnSeg !c !rad !p1 !p2 = + magV (p1 -.- c) <= rad + || magV (p2 -.- c) <= rad + || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) + where + thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) + +{- | Test whether a segment intersects a circle by intersecting a normal and testing + the distance to the endpoints of the segment. +-} segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool {-# INLINE segOnCirc #-} -segOnCirc !p1 !p2 !c !rad = magV (p1 -.- c) <= rad - || magV (p2 -.- c) <= rad - || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) - where +segOnCirc !p1 !p2 !c !rad = + magV (p1 -.- c) <= rad + || magV (p2 -.- c) <= rad + || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) + where thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) + cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool {-# INLINE cylinderOnSeg #-} cylinderOnSeg = undefined + -- | Find the difference between two Nums. difference :: (Ord a, Num a) => a -> a -> a {-# INLINE difference #-} -difference x y - | x > y = x - y +difference x y + | x > y = x - y | 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 line vec = rotateV (2 * angleBetween line vec) vec --- | Find angle between two points. --- Not normalised, ranges from -2*pi to 2*pi. +{- | Find angle between two points. + Not normalised, ranges from -2*pi to 2*pi. +-} angleBetween :: Point2 -> Point2 -> Float angleBetween v1 v2 = argV v1 - argV v2 + -- | Return a list containing two copies of a pair. -doublePair :: (a,a) -> [(a,a)] -doublePair (x,y) = [(x,y),(y,x)] +doublePair :: (a, a) -> [(a, a)] +doublePair (x, y) = [(x, y), (y, x)] -- this shouldn't be here -doublePairSet :: Ord a => (a,a) -> S.Set (a,a) -doublePairSet (x,y) = S.fromList [(x,y),(y,x)] +doublePairSet :: Ord a => (a, a) -> S.Set (a, a) +doublePairSet (x, y) = S.fromList [(x, y), (y, x)] doubleV2 :: V2 a -> [V2 a] -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'' _ = [] +doubleV2 (V2 x y) = [V2 x y, V2 y x] -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] {-# INLINE polyToTris' #-} polyToTris' [] = [] -polyToTris' (a:as) = prependTwo a as +polyToTris' (a : as) = prependTwo a as prependTwo :: a -> [a] -> [a] -prependTwo sep (x:y:xs) = sep : x : y : prependTwo sep (y:xs) +prependTwo sep (x : y : xs) = sep : x : y : prependTwo sep (y : xs) prependTwo _ _ = [] -- | Return n equidistant points on a circle with a radius of 600. nRays :: Int -> [Point2] nRays n = nRaysRad n 600 + -- | Return n equidistant points on a circle with a radius of x. nRaysRad :: Int -> Float -> [Point2] -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. --- This appears to sometimes fail if the angles are not normalized. +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. + This appears to sometimes fail if the angles are not normalized. +-} isLeftOfA :: Float -> Float -> Bool --isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2) -- || (angle2 - angle1 > pi && angle2 > angle1) 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 x y = isLeftOfA (argV x) (argV y) --- | Find the difference between two angles. --- Possibly not correct... --- TODO write tests + +{- | Find the difference between two angles. + Possibly not correct... + TODO write tests +-} diffAngles :: Float -> Float -> Float -diffAngles x y - | diff > pi = diffAngles (x - 2*pi) y - | diff >= 0 = diff - | diff > -pi = -diff - | otherwise = diffAngles (x + 2*pi) y - where - diff = x-y +diffAngles x y + | diff > pi = diffAngles (x - 2 * pi) y + | diff >= 0 = diff + | diff > - pi = - diff + | otherwise = diffAngles (x + 2 * pi) y + where + diff = x - y mixAngles :: Float -> Float -> Float -> Float mixAngles frac a1 a2 | abs (a1 - a2) <= pi = normalizeAngle $ frac * a1 + (1 - frac) * a2 - | a1 > a2 = mixAngles frac (a1 - 2*pi) a2 - | otherwise = mixAngles frac (a1 + 2*pi) a2 + | a1 > a2 = mixAngles frac (a1 - 2 * pi) a2 + | otherwise = mixAngles frac (a1 + 2 * pi) a2 -- | Return Just a point if it is inside a circle, Nothing otherwise. pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2 -pointInCircle p r c +pointInCircle p r c | p == c = Just p | magV (p -.- c) < r = Just p | otherwise = Nothing --- | Finds the height of a triangle using herons formula. --- The base is the line between the first two points. +{- | Finds the height of a triangle using herons formula. + The base is the line between the first two points. +-} heron :: Point2 -> Point2 -> Point2 -> Float -heron x y z +heron x y z | x == y = 0 - | otherwise = + | otherwise = let a = magV $ x -.- y b = magV $ y -.- z c = magV $ z -.- x - s = (a+b+c)/2 - area = sqrt(s*(s-a)*(s-b)*(s-c)) - in 2*area/a + s = (a + b + c) / 2 + area = sqrt (s * (s - a) * (s - b) * (s - c)) + in 2 * area / a + -- | Multiplies reflection in normal by factor. reflectInParam :: Float -> Point2 -> Point2 -> Point2 -reflectInParam x line vec = +reflectInParam x line vec = let angle = 2 * angleBetween line vec rAng = rotateV angle vec p = x *.* errorClosestPointOnLine 3 (V2 0 0) (vNormal line) rAng - in rAng -.- p + in rAng -.- p isOnSeg :: Point2 -> Point2 -> Point2 -> Bool -isOnSeg l1 l2 p = +isOnSeg l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 - && errorClosestPointOnLineParam 11 l1 l2 p <= 1 - && errorClosestPointOnLineParam 12 l1 l2 p >= 0 --- | Divide a segment into a list of points with a maximal distance between --- them. --- the take 5000 here is a hack, otherwise divideLine seems to sometimes --- generate an infinite list, and I don't know why + && errorClosestPointOnLineParam 11 l1 l2 p <= 1 + && errorClosestPointOnLineParam 12 l1 l2 p >= 0 + +{- | Divide a segment into a list of points with a maximal distance between + them. + 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 x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) -divideLine x a b = take 5000 - $ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) - ns - where +--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) +divideLine x a b = + take 5000 $ + map + (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a))) + ns + where d = dist a b numPoints = max 1 $ ceiling $ d / x ns = [0 :: Int .. numPoints] + -- | As 'divideLine', but must return an odd number of points. divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2] ---divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) -divideLineOddNumPoints x a b = take 5000 - $ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) - ns - where +--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) +divideLineOddNumPoints x a b = + take 5000 $ + map + (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a))) + ns + where d = dist a b numPoints' = max 1 $ ceiling $ d / x numPoints | even numPoints' = numPoints' - | otherwise = numPoints' + 1 + | otherwise = numPoints' + 1 ns = [0 .. numPoints] :: [Int] divideLineExact :: Float -> Point2 -> Point2 -> [Point2] -divideLineExact x a b = map ( (a +.+ ) . ( *.* v) ) [0 , x .. d] - where +divideLineExact x a b = map ((a +.+) . (*.* v)) [0, x .. d] + where d = dist a b v = normalizeV $ b -.- a - --- | Given two pairs of Ints, returns a list of pairs of Ints that form --- a digital line between them. -digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)] +{- | Given two pairs of Ints, returns a list of pairs of Ints that form + a digital line between them. +-} +digitalLine :: (Int, Int) -> (Int, Int) -> [(Int, Int)] --{-# INLINE digitalLine #-} -digitalLine (x1,y1) (x2,y2) - | abs (x1-x2) > abs (y1-y2) = - [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) ) - | x <- intervalList x1 x2 +digitalLine (x1, y1) (x2, y2) + | abs (x1 - x2) > abs (y1 - y2) = + [ (x, ((y1 - y2) * x + x1 * y2 - x2 * y1) `rdiv` (x1 - x2)) + | x <- intervalList x1 x2 ] - | otherwise = - [ ( ((x1-x2) * y + y1*x2 - y2*x1) `rdiv` (y1-y2) , y) - | y <- intervalList y1 y2 + | otherwise = + [ (((x1 - x2) * y + y1 * x2 - y2 * x1) `rdiv` (y1 - y2), y) + | y <- intervalList y1 y2 ] - where + where 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. -digitalRect :: (Int,Int) -> (Int,Int) -> [(Int,Int)] + +{- | 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)] {-# 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]] where maxx = max a c minx = min a c maxy = max b d miny = min b d + -- | Given two Ints, creates the list of Ints between these. intervalList :: Int -> Int -> [Int] {-# INLINE intervalList #-} -intervalList x y +intervalList x y | y > x = [x .. y] - | otherwise = reverse [y..x] --- | Create points on the circumference of a circle with maximal distance --- between them. + | otherwise = reverse [y .. x] + +{- | Create points on the circumference of a circle with maximal distance + between them. +-} divideCircle :: Float -> Point2 -> Float -> [Point2] divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad - where + where n = ceiling $ rad * 2 * pi / x -arcStepwise - :: Float -- ^ Maximum distance between points - -> Float -- ^ Angle to travel - -> Point2 -- ^ Center - -> Point2 -- ^ Start vector from center - -> [Point2] +arcStepwise :: + -- | Maximum distance between points + Float -> + -- | Angle to travel + Float -> + -- | Center + Point2 -> + -- | Start vector from center + Point2 -> + [Point2] arcStepwise ssize a c v | a < 0 = reverse $ arcStepwisePositive ssize (negate a) c (rotateV a v) | otherwise = arcStepwisePositive ssize a c v -arcStepwisePositive - :: Float -- ^ Maximum distance between points - -> Float -- ^ Angle to travel, assumed to be positive - -> Point2 -- ^ Center - -> Point2 -- ^ Start vector from center - -> [Point2] +arcStepwisePositive :: + -- | Maximum distance between points + Float -> + -- | Angle to travel, assumed to be positive + Float -> + -- | Center + Point2 -> + -- | Start vector from center + Point2 -> + [Point2] arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots where rots :: [Float] - rots = map ((a*) . (/ fromIntegral n ) . fromIntegral) [0 .. n] + rots = map ((a *) . (/ fromIntegral n) . fromIntegral) [0 .. n] n :: Int n = ceiling (a * magV v / ssize) --- | Given a list of points, returns pairs of points linking the points into a --- loop. -chainPairs :: [Point2] -> [(Point2,Point2)] +{- | Given a list of points, returns pairs of points linking the points into a + loop. +-} +chainPairs :: [Point2] -> [(Point2, Point2)] chainPairs [] = error "tried to make chain with empty list of points" chainPairs [_] = error "tried to make chain with singleton list of points" chainPairs xs = zip xs $ tail xs --- | Given a list of points, returns pairs of points linking the points into a --- loop. ---loopPairs :: [a] -> [(a,a)] ---loopPairs [] = error "tried to make loop with empty list of elements" ---loopPairs [_] = error "tried to make loop with singleton list of elements" ---loopPairs (x:xs) = zip (x:xs) (xs ++ [x]) --- | Test whether a point is in a cone. --- Note the pair is ordered. --- Doesn't work for obtuse angles. -pointIsInCone - :: Point2 -- ^ Cone point. - -> (Point2,Point2) -- ^ Points delimiting the left and right boundaries of the cone. - -> Point2 -- ^ Point to test. - -> Bool -pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p +{- | Given a list of points, returns pairs of points linking the points into a + loop. +loopPairs :: [a] -> [(a,a)] +loopPairs [] = error "tried to make loop with empty list of elements" +loopPairs [_] = error "tried to make loop with singleton list of elements" +loopPairs (x:xs) = zip (x:xs) (xs ++ [x]) + | Test whether a point is in a cone. + Note the pair is ordered. + Doesn't work for obtuse angles. +-} +pointIsInCone :: + -- | Cone point. + Point2 -> + -- | 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 diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 00730e6c7..62019a70d 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -127,15 +127,15 @@ preloadRender = do poke (shadVBOptr shadowlightshader) 1 -- 2D draw shaders - bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles - bslista <- makeShader4 "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp pmTriangles shVBO + bslist <- makeShaderVBO "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles + bslista <- makeShaderUsingVBO "shape/basic" [vert, frag] shapeVerxSizes nShapeVerxComp pmTriangles shVBO glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) (shEBO' ^. eboName) --glVertexArrayElementBuffer (bslista ^. shaderVAO . vaoName) shEBOname - aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles - eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles + aslist <- makeShaderVBO "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles + eslist <- makeShaderVBO "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles cslist <- - makeShader "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles - addBindTextureArray 50 "data/texture/charMapVert.png" 2 16 32 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR + makeShaderVBO "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles + initTexture2DArray 50 "data/texture/charMapVert.png" 2 16 32 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR screentexturevbo <- mglCreate glCreateBuffers withArray (concat cornerList) $ \ptr -> @@ -145,26 +145,24 @@ preloadRender = do ptr 0 screentexturevao <- setupVAOvbo' [2,2] 4 screentexturevbo - alphadivideshader <- makeShader4UsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao - fsShad <- makeShader4UsingVAO "texture/simple" [vert, frag] pmTriangleStrip screentexturevao + alphadivideshader <- makeShaderUsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao + fsShad <- makeShaderUsingVAO "texture/simple" [vert, frag] pmTriangleStrip screentexturevao bloomBlurShad <- makeShaderUsingVAO "texture/bloomBlur" [vert, frag] pmTriangleStrip screentexturevao colorBlurShad <- makeShaderUsingVAO "texture/colorBlur" [vert, frag] pmTriangleStrip screentexturevao grayscaleShad <- makeShaderUsingVAO "texture/grayscale" [vert, frag] pmTriangleStrip screentexturevao lightingTextureShad <- 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 wallBlankShad <- makeShaderUsingVAO "wall/blank" [vert, geom, frag] pmPoints wpColVAO let wallverxstrd = 8 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 floorvbo <- setupVBOStatic floorverxstrd - floorshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4] floorverxstrd pmTriangles floorvbo - todiffusemap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png" - tonormalmap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png" - glBindTextureUnit 40 (todiffusemap ^. unTO) - glBindTextureUnit 41 (tonormalmap ^. unTO) + floorshader <- makeShaderUsingVBO "floor/arrayPos" [vert, frag] [4,4] floorverxstrd pmTriangles floorvbo + initTexture2DArraySquare 40 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png" + initTexture2DArraySquare 41 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png" let cloudverxsizes = [4,4,4,4] cloudvbo <- setupVBO (sum cloudverxsizes) @@ -220,7 +218,6 @@ preloadRender = do , _shadowWallShader = shadowwallshader , _shadowLightShader = shadowlightshader , _shadowCombineShader = shadowcombineshader - , _wallBlankShader = wallBlankShad , _windowShader = wallBlankShad{_shaderVAO = winColVAO} , _fullscreenShader = fsShad , _alphaDivideShader = alphadivideshader @@ -249,8 +246,6 @@ preloadRender = do , _vboShapes = shVBO , _floorVBO = floorvbo , _floorShader = floorshader - , _texaNormalMaps = tonormalmap - , _texaDiffuse = todiffusemap , _wallVBO = wallvbo , _wallShader = wallshader , _cloudVBO = cloudvbo diff --git a/src/Render.hs b/src/Render.hs index 5592f455e..d933edb8c 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -2,7 +2,6 @@ module Render ( createLightMap, renderLayer, pingPongBetween, - bindTO, bindFBO, ) where @@ -28,8 +27,7 @@ import Shader.Data -} createLightMap :: Configuration -> - RenderData -> - [(Point3, Float, Point3)] -> -- Lights + ShadowRendering -> -- | number of walls Int -> @@ -37,173 +35,188 @@ createLightMap :: Int -> -- | number of "caps" to attempt to draw Int -> - -- | whether to draw object shadows or not - ObjectShadows -> -- | the texture object giving positions TO -> -- | the texture object giving normals TO -> + [(Point3, Float, Point3)] -> -- Lights + RenderData -> IO () -createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype - positiontexture - normaltexture - = case shadsdrawtype of - InstancingShads -> instanceLightMap cfig pdata lightPoints nWalls nSils nCaps positiontexture - NoShadows -> do - glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) - let ltextShad = _lightingTextureShader pdata - -- we assume that the renderbuffer's depth has been correctly set elsewhere - -- we will not be changing that here - glDepthMask GL_FALSE - -- clearColor is specified differently in preloadRender - -- the colors are inverted - withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv +createLightMap cfig shadrendertype = case shadrendertype of + InstancingShads -> instanceLightMap cfig + NoShadows -> const . const . const renderLightingNoShadows + NoLighting -> const . const . const . const . const . const renderFlatLighting + _ -> renderShadows shadrendertype + +renderLightingNoShadows :: + TO -> + TO -> + [(V3 GLfloat, GLfloat, V3 GLfloat)] -> + RenderData -> + IO () +renderLightingNoShadows positiontexture normaltexture lightPoints pdata = do + glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) + let ltextShad = _lightingTextureShader pdata + -- we assume that the renderbuffer's depth has been correctly set elsewhere + -- we will not be changing that here + glDepthMask GL_FALSE + -- clearColor is specified differently in preloadRender + -- the colors are inverted + withArray [1, 1, 1, 1] $ \ptr -> + glClearNamedFramebufferfv (pdata ^. fboLighting . _1 . unFBO) GL_COLOR 0 ptr - -- for each of the lights: - -- 1. stencil out the shadows from this light's point of view - -- 2. calculate lighting based on each fragment's position - -- to consider: adding normals/a "material" for each fragment - glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR - glEnable GL_STENCIL_TEST - glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP - glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP - flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do - glDepthFunc GL_LESS - -- setup stencil - glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE - with 0 $ \ptr -> glClearNamedFramebufferiv + -- for each of the lights: + -- 1. stencil out the shadows from this light's point of view + -- 2. calculate lighting based on each fragment's position + -- to consider: adding normals/a "material" for each fragment + glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR + glEnable GL_STENCIL_TEST + glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP + glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP + flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do + glDepthFunc GL_LESS + -- setup stencil + glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE + with 0 $ \ptr -> + glClearNamedFramebufferiv (pdata ^. fboLighting . _1 . unFBO) GL_STENCIL - 0 - ptr - glDisable GL_CULL_FACE - glStencilFunc GL_ALWAYS 0 255 - --draw lightmap itself - glDepthFunc GL_ALWAYS - -- bind world position texture - glBindTextureUnit 0 (positiontexture ^. unTO) - glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE - glStencilFunc GL_EQUAL 0 255 - glUseProgram (ltextShad ^. shaderUINT) - glUniform3f 0 x y z - glUniform4f 1 r g b rad - glBindVertexArray $ ltextShad ^. shaderVAO . vaoName - glDrawArrays - (_unPrimitiveMode (_shaderPrimitive ltextShad)) 0 - (fromIntegral (4 :: Int)) - --cleanup: may not be necessary, depending on what comes after... + ptr glDisable GL_CULL_FACE - glDisable GL_STENCIL_TEST - NoLighting -> do - glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) - glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR - withArray [0,0,0,1] $ \ptr -> glClearNamedFramebufferfv + glStencilFunc GL_ALWAYS 0 255 + --draw lightmap itself + glDepthFunc GL_ALWAYS + -- bind world position texture + glBindTextureUnit 0 (positiontexture ^. unTO) + glBindTextureUnit 1 (normaltexture ^. unTO) + glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE + glStencilFunc GL_EQUAL 0 255 + glUseProgram (ltextShad ^. shaderUINT) + glUniform3f 0 x y z + glUniform4f 1 r g b rad + glBindVertexArray $ ltextShad ^. shaderVAO . vaoName + glDrawArrays + (_unPrimitiveMode (_shaderPrimitive ltextShad)) + 0 + (fromIntegral (4 :: Int)) + --cleanup: may not be necessary, depending on what comes after... + glDisable GL_CULL_FACE + glDisable GL_STENCIL_TEST + +renderFlatLighting :: RenderData -> IO () +renderFlatLighting pdata = do + glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) + withArray [1, 1, 1, 1] $ \ptr -> + glClearNamedFramebufferfv (pdata ^. fboLighting . _1 . unFBO) GL_COLOR 0 ptr - with 1 $ \ptr -> glClearNamedFramebufferfv + with 1 $ \ptr -> + glClearNamedFramebufferfv (pdata ^. fboLighting . _1 . unFBO) GL_DEPTH 0 ptr - glDisable GL_CULL_FACE - glBindTextureUnit 0 (positiontexture ^. unTO) - glDepthFunc GL_ALWAYS - glDepthMask GL_FALSE - _ -> do - glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) - let llinesShad = _lightingLineShadowShader pdata - lcapShad = _lightingCapShader pdata - lwallShad = _lightingWallShadShader pdata - ltextShad = _lightingTextureShader pdata - -- we assume that the renderbuffer's depth has been correctly set elsewhere - -- we will not be changing that here - glDepthMask GL_FALSE - -- clearColor is specified differently in preloadRender - -- the colors are inverted - withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv - (pdata ^. fboLighting . _1 . unFBO) - GL_COLOR - 0 - ptr - -- for each of the lights: - -- 1. stencil out the shadows from this light's point of view - -- 2. calculate lighting based on each fragment's position - -- to consider: adding normals/a "material" for each fragment - glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR - glEnable GL_STENCIL_TEST - glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP - glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP - flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do - glDepthFunc GL_LESS - -- setup stencil - glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE - with 0 $ \ptr -> glClearNamedFramebufferiv - (pdata ^. fboLighting . _1 . unFBO) - GL_STENCIL - 0 - ptr - glDisable GL_CULL_FACE - glStencilFunc GL_ALWAYS 0 255 - --draw wall shadows - glUseProgram (_shaderUINT lwallShad) - glUniform3f 0 x y z - glUniform1f 1 rad - glBindVertexArray $ lwallShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO lwallShad) - glDrawArrays - (_unPrimitiveMode $ _shaderPrimitive lwallShad) - 0 - (fromIntegral nWalls) - case shadsdrawtype of - GeoObjShads -> do - --draw silhouette shadows - glEnable GL_DEPTH_CLAMP - glUseProgram (_shaderUINT llinesShad) - glUniform3f 0 x y z - glUniform1f 1 rad - glBindVertexArray (_vaoName $ _shaderVAO llinesShad) - glDrawElements - (_unPrimitiveMode $ _shaderPrimitive llinesShad) - (fromIntegral nSils) - GL_UNSIGNED_SHORT - nullPtr - --draw caps on the near plane as required - glEnable GL_CULL_FACE - glCullFace GL_BACK - glCullFace GL_FRONT - glUseProgram (_shaderUINT lcapShad) - glUniform3f 0 x y z - glBindVertexArray $ lcapShad ^. shaderVAO . vaoName --Just (_vao $ _shadVAO lcapShad) - glDrawElements - (_unPrimitiveMode $ _shaderPrimitive lcapShad) - (fromIntegral nCaps) - GL_UNSIGNED_SHORT - nullPtr - glDisable GL_DEPTH_CLAMP - NoObjShads -> return () - --draw lightmap itself - glDepthFunc GL_ALWAYS - -- bind world position texture - glDisable GL_CULL_FACE - glBindTextureUnit 0 (positiontexture ^. unTO) - glBindTextureUnit 1 (normaltexture ^. unTO) - glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE - glStencilFunc GL_EQUAL 0 255 - glUseProgram (ltextShad ^. shaderUINT) --Just (_shadProg ltextShad) - glUniform3f 0 x y z - glUniform4f 1 r g b rad - glBindVertexArray $ ltextShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO ltextShad) - glDrawArrays - (_unPrimitiveMode (_shaderPrimitive ltextShad)) - 0 - (fromIntegral (4 :: Int)) - --cleanup: may not be necessary, depending on what comes after... - glDisable GL_STENCIL_TEST + glDisable GL_CULL_FACE + glDepthFunc GL_ALWAYS + glDepthMask GL_FALSE + +renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture lightPoints pdata = do + glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) + let llinesShad = _lightingLineShadowShader pdata + lcapShad = _lightingCapShader pdata + lwallShad = _lightingWallShadShader pdata + ltextShad = _lightingTextureShader pdata + -- we assume that the renderbuffer's depth has been correctly set elsewhere + -- we will not be changing that here + glDepthMask GL_FALSE + -- clearColor is specified differently in preloadRender + -- the colors are inverted + withArray [1, 1, 1, 1] $ \ptr -> + glClearNamedFramebufferfv + (pdata ^. fboLighting . _1 . unFBO) + GL_COLOR + 0 + ptr + -- for each of the lights: + -- 1. stencil out the shadows from this light's point of view + -- 2. calculate lighting based on each fragment's position + -- to consider: adding normals/a "material" for each fragment + glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR + glEnable GL_STENCIL_TEST + glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP + glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP + flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do + glDepthFunc GL_LESS + -- setup stencil + glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE + with 0 $ \ptr -> + glClearNamedFramebufferiv + (pdata ^. fboLighting . _1 . unFBO) + GL_STENCIL + 0 + ptr + glDisable GL_CULL_FACE + glStencilFunc GL_ALWAYS 0 255 + --draw wall shadows + glUseProgram (_shaderUINT lwallShad) + glUniform3f 0 x y z + glUniform1f 1 rad + glBindVertexArray $ lwallShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO lwallShad) + glDrawArrays + (_unPrimitiveMode $ _shaderPrimitive lwallShad) + 0 + (fromIntegral nWalls) + case shadrendertype of + GeoObjShads -> do + --draw silhouette shadows + glEnable GL_DEPTH_CLAMP + glUseProgram (_shaderUINT llinesShad) + glUniform3f 0 x y z + glUniform1f 1 rad + glBindVertexArray (_vaoName $ _shaderVAO llinesShad) + glDrawElements + (_unPrimitiveMode $ _shaderPrimitive llinesShad) + (fromIntegral nSils) + GL_UNSIGNED_SHORT + nullPtr + --draw caps on the near plane as required + glEnable GL_CULL_FACE + glCullFace GL_BACK + glCullFace GL_FRONT + glUseProgram (_shaderUINT lcapShad) + glUniform3f 0 x y z + glBindVertexArray $ lcapShad ^. shaderVAO . vaoName --Just (_vao $ _shadVAO lcapShad) + glDrawElements + (_unPrimitiveMode $ _shaderPrimitive lcapShad) + (fromIntegral nCaps) + GL_UNSIGNED_SHORT + nullPtr + glDisable GL_DEPTH_CLAMP + NoObjShads -> return () + --draw lightmap itself + glDepthFunc GL_ALWAYS + -- bind world position texture + glDisable GL_CULL_FACE + glBindTextureUnit 0 (positiontexture ^. unTO) + glBindTextureUnit 1 (normaltexture ^. unTO) + glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE + glStencilFunc GL_EQUAL 0 255 + glUseProgram (ltextShad ^. shaderUINT) --Just (_shadProg ltextShad) + glUniform3f 0 x y z + glUniform4f 1 r g b rad + glBindVertexArray $ ltextShad ^. shaderVAO . vaoName -- Just (_vao $ _shadVAO ltextShad) + glDrawArrays + (_unPrimitiveMode (_shaderPrimitive ltextShad)) + 0 + (fromIntegral (4 :: Int)) + --cleanup: may not be necessary, depending on what comes after... + glDisable GL_STENCIL_TEST lightsToArray :: [(Point3, Float, Point3)] -> [Float] lightsToArray xs = @@ -213,11 +226,9 @@ lightsToArray xs = t (V3 a b c, _, _) = [a, b, c, 1] s (_, d, V3 e f g) = [e, f, g, d] - instanceLightMap :: Configuration -> - RenderData -> - [(Point3, Float, Point3)] -> -- Lights + -- | number of walls Int -> -- | number of silhoutte lines to draw @@ -226,8 +237,11 @@ instanceLightMap :: Int -> -- | the texture object giving positions TO -> + TO -> + [(Point3, Float, Point3)] -> -- Lights + RenderData -> IO () -instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do +instanceLightMap cfig nWalls nSils nCaps toPos tanormals lightPoints pdata = do let lcapShad = _shadowCapShader pdata (xsize, ysize) = getWindowSize cfig withArray (lightsToArray lightPoints) $ \ptr -> @@ -251,16 +265,18 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do 1 glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboShadow . _1 . unFBO glDepthMask GL_FALSE - withArray [0,0,0,0] $ \ptr -> glClearNamedFramebufferfv - (pdata ^. fboShadow . _1 . unFBO) - GL_COLOR - 0 - ptr - with 0 $ \ptr -> glClearNamedFramebufferiv - (pdata ^. fboShadow . _1 . unFBO) - GL_STENCIL - 0 - ptr + withArray [0, 0, 0, 0] $ \ptr -> + glClearNamedFramebufferfv + (pdata ^. fboShadow . _1 . unFBO) + GL_COLOR + 0 + ptr + with 0 $ \ptr -> + glClearNamedFramebufferiv + (pdata ^. fboShadow . _1 . unFBO) + GL_STENCIL + 0 + ptr -- stencil out the shadows from each light's point of view -- setup stencil glEnable GL_STENCIL_TEST @@ -303,8 +319,7 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do glStencilFunc GL_EQUAL 0 255 glUseProgram (pdata ^. shadowLightShader . _1 . shaderUINT) -- bind world position texture - bindTO toPos --- glBindVertexArray $ pdata ^. shadowLightShader . shaderVAO' . vaoName + glBindTextureUnit 0 (toPos ^. unTO) glDrawArrays (_unPrimitiveMode $ pdata ^. shadowLightShader . _1 . shaderPrimitive) 0 @@ -313,12 +328,13 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do glDisable GL_STENCIL_TEST --draw to the lighting framebuffer here glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) - withArray [1,1,1,1] $ \ptr -> glClearNamedFramebufferfv - (pdata ^. fboLighting . _1 . unFBO) - GL_COLOR - 0 - ptr - glBindTexture GL_TEXTURE_2D_ARRAY (pdata ^. fboShadow . _2 . _1 . unTO) + withArray [1, 1, 1, 1] $ \ptr -> + glClearNamedFramebufferfv + (pdata ^. fboLighting . _1 . unFBO) + GL_COLOR + 0 + ptr + glBindTextureUnit 0 (pdata ^. fboShadow . _2 . _1 . unTO) glEnable GL_BLEND glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glUseProgram (pdata ^. shadowCombineShader . _1 . shaderUINT) @@ -339,20 +355,16 @@ pingPongBetween :: Shader -> IO () pingPongBetween (fb1, to1) (fb2, to2) fs = do - --bindFramebuffer Framebuffer $= fb2 glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb2) - --textureBinding Texture2D $= Just to1 - glBindTexture GL_TEXTURE_2D (_unTO to1) + glBindTextureUnit 0 (_unTO to1) drawShader fs 4 - --bindFramebuffer Framebuffer $= fb1 glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb1) - --textureBinding Texture2D $= Just to2 - glBindTexture GL_TEXTURE_2D (_unTO to2) + glBindTextureUnit 0 (_unTO to2) drawShader fs 4 renderLayer :: Layer -> - MV.MVector (PrimState IO) (Shader,VBO) -> + MV.MVector (PrimState IO) (Shader, VBO) -> UMV.MVector (PrimState IO) Int -> IO () renderLayer layer shads counts = do @@ -361,11 +373,6 @@ renderLayer layer shads counts = do where ln = layerNum layer -bindTO :: TO -> IO () -bindTO t = glBindTexture GL_TEXTURE_2D (_unTO t) - ---textureBinding Texture2D $= Just t - bindFBO :: FBO -> IO () bindFBO fb = --bindFramebuffer Framebuffer $= fb diff --git a/src/Shader.hs b/src/Shader.hs index 179707d83..df77361ee 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -6,7 +6,6 @@ module Shader ( ) where import Control.Lens -import Control.Monad import Control.Monad.Primitive import qualified Data.Vector.Unboxed.Mutable as UMV import Foreign @@ -20,7 +19,6 @@ drawShaderLay l countsVector shadIn fs = do i <- UMV.read countsVector shadIn glUseProgram (_shaderUINT $ fst fs) glBindVertexArray $ fs ^. _1 . shaderVAO . vaoName - zipWithM_ (\ti -> glBindTextureUnit ti . _unTO) [0 ..] (fs ^. _1 . shaderTextures) glDrawArrays (_unPrimitiveMode $ _shaderPrimitive $ fst fs) (fromIntegral $ l * numSubElements) @@ -31,7 +29,6 @@ drawShader :: Shader -> Int -> IO () drawShader fs i = do glUseProgram (_shaderUINT fs) glBindVertexArray $ fs ^. shaderVAO . vaoName - zipWithM_ (\ti -> glBindTextureUnit ti . _unTO) [0..] (fs ^. shaderTextures) glDrawArrays (_unPrimitiveMode $ _shaderPrimitive fs) 0 diff --git a/src/Shader/AuxAddition.hs b/src/Shader/AuxAddition.hs index 8dacd85f1..a7730e313 100644 --- a/src/Shader/AuxAddition.hs +++ b/src/Shader/AuxAddition.hs @@ -1,128 +1,58 @@ -module Shader.AuxAddition - ( addSamplerTexture2D - , vaddTextureNoFilter - , addTextureArray - , addBindTextureArray - , initTexture2D - , initTexture2DArray - , tilesToLine - ) where -import LensHelp -import Unsafe.Coerce -import Shader.Data -import Data.List.Extra +module Shader.AuxAddition ( + initTexture2DArray, + initTexture2DArraySquare, + tilesToLine, +) where + import Codec.Picture +import Data.List.Extra import qualified Data.Vector.Storable as VS -import Graphics.GL.Core45 import GLHelp - --- I am not sure if this assumes that the shader is constructed directly before --- 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 +import Graphics.GL.Core45 +import Unsafe.Coerce -- assumes the texture slices are squares with sides as long as the input is -- wide -initTexture2DArray - :: GLint -- number of mipmap levels - -> GLenum -- minfilter - -> GLenum -- magfilter - -> String -> IO TO -initTexture2DArray nlev minfilt magfilt fp = do +initTexture2DArraySquare :: + GLuint -> -- binding point + GLint -> -- number of mipmap levels + GLenum -> -- minfilter + GLenum -> -- magfilter + String -> + IO () +initTexture2DArraySquare bindpoint nlev minfilt magfilt fp = do Right cmap <- readImage fp let texdata = convertRGBA8 cmap - let wtex = fromIntegral $ imageWidth texdata - htex = fromIntegral $ imageHeight texdata - z = htex `div` wtex - texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY - 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 + let sqside = fromIntegral $ imageWidth texdata + totalh = fromIntegral $ imageHeight texdata + d = totalh `div` sqside + initTexture2DArrayData bindpoint texdata nlev sqside sqside d minfilt magfilt --- | for transforming a 256x256 image containing 64 tiles of 16x16 pixels into --- an image that was directly readable by glTexSubImage3D, used the --- transformation tilesToLine 8 128 on the underlying pixels. -addTextureArray :: String -> (Shader,VBO) -> IO (Shader,VBO) -addTextureArray texturePath (shad,vbo) = do - err <- glGetError - print err - Right cmap <- readImage texturePath - let texdata = convertRGBA8 cmap - texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY - glTextureStorage3D texname 3 GL_RGBA8 32 32 64 - 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 +initTexture2DArray :: + GLuint -> + String -> + GLsizei -> + GLsizei -> + GLsizei -> + GLsizei -> + GLenum -> + GLenum -> + IO () +initTexture2DArray bindpoint fp nlev w h d minfilt magfilt = do Right cmap <- readImage fp let texdata = convertRGBA8 cmap initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt -initTexture2DArrayData :: GLuint -> Image PixelRGBA8 -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum - -> IO () +initTexture2DArrayData :: + GLuint -> + Image PixelRGBA8 -> + GLsizei -> + GLsizei -> + GLsizei -> + GLsizei -> + GLenum -> + GLenum -> + IO () initTexture2DArrayData bindpoint texdata nlev w h d minfilt magfilt = do texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY 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) glBindTextureUnit bindpoint texname -tilesToLine - :: Int -- ^ Parameter a - -> Int -- ^ Parameter b - -> [a] - -> [a] +tilesToLine :: + -- | Parameter a + Int -> + -- | Parameter b + Int -> + [a] -> + [a] tilesToLine n w = concat . concat . transpose . chunksOf n . chunksOf w diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index 852f57b07..afb6a726c 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -2,9 +2,8 @@ module Shader.Compile ( setupVBO, setupVBOStatic, makeShaderEBO, - makeShader, - makeShader4, - makeShader4UsingVAO, + makeShaderVBO, + makeShaderUsingVBO, makeByteStringShaderUsingVAO, makeShaderSized, makeShaderUsingVAO, @@ -25,13 +24,14 @@ import GLHelp import Graphics.GL.Core45 import Shader.Data import Shader.Parameters + --import Graphics.GL.Core45 {- | 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. -} -makeShader :: +makeShaderVBO :: -- | First part of the name of the shader String -> -- | shader types @@ -39,17 +39,18 @@ makeShader :: -- | The input vertex sizes [Int] -> PrimitiveMode -> - IO (Shader,VBO) -makeShader s shaderlist sizes pm = do + IO (Shader, VBO) +makeShaderVBO s shaderlist sizes pm = do prog <- makeSourcedShader s shaderlist - (vao,vbo) <- setupVAO sizes - return ( Shader + (vao, vbo) <- setupVAO sizes + return + ( Shader { _shaderUINT = prog , _shaderVAO = vao , _shaderPrimitive = pm - , _shaderTextures = mempty } - , vbo) + , vbo + ) makeShaderEBO :: -- | 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 ebo <- setupEBO vao return - ( Shader prog pm vao [] + ( Shader prog pm vao , ebo ) -makeShader4 :: +makeShaderUsingVBO :: -- | First part of the name of the shader String -> -- | shader types @@ -84,54 +85,32 @@ makeShader4 :: PrimitiveMode -> VBO -> IO Shader -makeShader4 s shaderlist sizes strd pm vbo = do - prog <- makeSourcedShader s shaderlist - 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 = [] - } +makeShaderUsingVBO s shaderlist sizes strd pm vbo = setupVAOvbo sizes strd vbo + >>= makeShaderUsingVAO s shaderlist pm setupVBO :: Int -> IO VBO setupVBO vertexsize = do vboname <- mglCreate glCreateBuffers thePtr <- mallocArray (vertexsize * numDrawableElements) -- Allocate space - glNamedBufferData vboname - ( fromIntegral $ floatSize * numDrawableElements * vertexsize) - nullPtr + glNamedBufferData + vboname + (fromIntegral $ floatSize * numDrawableElements * vertexsize) + nullPtr GL_STREAM_DRAW - return VBO {_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize} + return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize} setupVBOStatic :: Int -> IO VBO setupVBOStatic vertexsize = do vboname <- mglCreate glCreateBuffers thePtr <- mallocArray (vertexsize * numDrawableElements) -- Allocate space - glNamedBufferData vboname - ( fromIntegral $ floatSize * numDrawableElements * vertexsize) - nullPtr + glNamedBufferData + vboname + (fromIntegral $ floatSize * numDrawableElements * vertexsize) + nullPtr GL_STATIC_DRAW - return VBO {_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize} + return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize} makeByteStringShaderUsingVAO :: -- | (Arbitrary) name of the shader @@ -143,12 +122,11 @@ makeByteStringShaderUsingVAO :: IO Shader makeByteStringShaderUsingVAO s shaderlist pm vao = do prog <- makeShaderProgram s shaderlist - return $ + return Shader { _shaderUINT = prog , _shaderVAO = vao , _shaderPrimitive = pm - , _shaderTextures = mempty } -- | Takes the VAO from elsewhere @@ -162,12 +140,11 @@ makeShaderUsingVAO :: IO Shader makeShaderUsingVAO s shaderlist pm theVAO = do prog <- makeSourcedShader s shaderlist - return $ + return Shader { _shaderUINT = prog , _shaderVAO = theVAO , _shaderPrimitive = pm - , _shaderTextures = mempty } {- | @@ -184,17 +161,18 @@ makeShaderSized :: -- | Number of vertexes that can be poked Int -> PrimitiveMode -> - IO (Shader,VBO) + IO (Shader, VBO) makeShaderSized s shaderlist sizes ndraw pm = do prog <- makeSourcedShader s shaderlist - (vao,vbo) <- setupVAOSized ndraw sizes - return ( Shader + (vao, vbo) <- setupVAOSized ndraw sizes + return + ( Shader { _shaderUINT = prog , _shaderVAO = vao , _shaderPrimitive = pm - , _shaderTextures = mempty } - , vbo) + , vbo + ) {- | Compile shader and get its uniform locations. supposes the shader code is in the shader folder, with the string names @@ -202,17 +180,17 @@ makeShaderSized s shaderlist sizes ndraw pm = do -} makeSourcedShader :: String -> [GLenum] -> IO GLuint 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 -shaderTypeExt' :: GLenum -> String -shaderTypeExt' GL_VERTEX_SHADER = ".vert" -shaderTypeExt' GL_GEOMETRY_SHADER = ".geom" -shaderTypeExt' GL_FRAGMENT_SHADER = ".frag" -shaderTypeExt' _ = undefined +shaderTypeExt :: GLenum -> String +shaderTypeExt GL_VERTEX_SHADER = ".vert" +shaderTypeExt GL_GEOMETRY_SHADER = ".geom" +shaderTypeExt GL_FRAGMENT_SHADER = ".frag" +shaderTypeExt _ = undefined -- I think that this requires that the correct shader program is bound? -setupVAO :: [Int] -> IO (VAO,VBO) +setupVAO :: [Int] -> IO (VAO, VBO) setupVAO = setupVAOSized numDrawableElements setupVAOvbo' :: [Int] -> Int -> GLuint -> IO VAO @@ -220,17 +198,18 @@ setupVAOvbo' sizes strd vbo = do vaoname <- mglCreate glCreateVertexArrays glBindVertexArray vaoname setupVertexAttribs' vbo vaoname sizes strd - return $ VAO + return $ + VAO { _vaoName = vaoname } - setupVAOvbo :: [Int] -> Int -> VBO -> IO VAO setupVAOvbo sizes strd vbo = do vaoname <- mglCreate glCreateVertexArrays glBindVertexArray vaoname setupVertexAttribs vbo vaoname sizes strd - return $ VAO + return $ + VAO { _vaoName = vaoname } @@ -238,37 +217,40 @@ setupEBO :: VAO -> IO EBO setupEBO vao = do eboptr <- mallocArray numDrawableElements eboname <- mglCreate glCreateBuffers - glNamedBufferData + glNamedBufferData eboname - ( fromIntegral $ glushortSize * numDrawableElements) - nullPtr + (fromIntegral $ glushortSize * numDrawableElements) + nullPtr GL_STREAM_DRAW glVertexArrayElementBuffer (vao ^. vaoName) eboname return $ EBO eboname eboptr -setupVAOSized :: Int -> [Int] -> IO (VAO,VBO) +setupVAOSized :: Int -> [Int] -> IO (VAO, VBO) setupVAOSized ndraw sizes = do vaoname <- mglCreate glCreateVertexArrays glBindVertexArray vaoname theVBO <- setupVBOSized ndraw vaoname sizes - return ( VAO + return + ( VAO { _vaoName = vaoname } - , theVBO) + , theVBO + ) setupVBOSized :: Int -> GLuint -> [Int] -> IO VBO setupVBOSized ndraw vao sizes = do --vboName <- genObjectName --bindBuffer ArrayBuffer $= Just vboName vboname <- mglCreate glCreateBuffers - glVertexArrayVertexBuffer vao 0 vboname 0 (fromIntegral $ floatSize * strd) + glVertexArrayVertexBuffer vao 0 vboname 0 (fromIntegral $ floatSize * strd) forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do setupVertexAttribPointer vao loc siz off thePtr <- mallocArray (strd * ndraw) -- Allocate space - glNamedBufferData vboname - ( fromIntegral $ floatSize * ndraw * strd) - nullPtr + glNamedBufferData + vboname + (fromIntegral $ floatSize * ndraw * strd) + nullPtr GL_STREAM_DRAW return $ VBO @@ -282,7 +264,7 @@ setupVBOSized ndraw vao sizes = do setupVertexAttribs :: VBO -> GLuint -> [Int] -> Int -> IO () setupVertexAttribs vbo vao sizes strd = do - glVertexArrayVertexBuffer vao 0 (_vboName vbo) 0 (fromIntegral $ floatSize * strd) + glVertexArrayVertexBuffer vao 0 (_vboName vbo) 0 (fromIntegral $ floatSize * strd) forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do setupVertexAttribPointer vao loc siz off where @@ -290,7 +272,7 @@ setupVertexAttribs vbo vao sizes strd = do setupVertexAttribs' :: GLuint -> GLuint -> [Int] -> Int -> IO () setupVertexAttribs' vbo vao sizes strd = do - glVertexArrayVertexBuffer vao 0 vbo 0 (fromIntegral $ floatSize * strd) + glVertexArrayVertexBuffer vao 0 vbo 0 (fromIntegral $ floatSize * strd) forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do setupVertexAttribPointer vao loc siz off where @@ -356,7 +338,7 @@ compileAndCheckShader str (theShaderType, sourceCode) = do setShaderSource theShader sourceCode glCompileShader theShader checkErrorGL - (str ++ shaderTypeExt' theShaderType) + (str ++ shaderTypeExt theShaderType) glGetShaderiv glGetShaderInfoLog theShader @@ -375,4 +357,3 @@ withByteString :: Num t => BS.ByteString -> (Ptr b -> t -> IO a) -> IO a withByteString bs act = BU.unsafeUseAsCStringLen bs $ \(ptr, size) -> act (castPtr ptr) (fromIntegral size) - diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index 029468a07..188245886 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -16,7 +16,6 @@ module Shader.Data ( shaderUINT, shaderPrimitive, shaderVAO, - shaderTextures, textureObject, vboName, vboPtr, @@ -51,7 +50,6 @@ data Shader = Shader { _shaderUINT :: GLuint -- should be shaderID , _shaderPrimitive :: PrimitiveMode , _shaderVAO :: VAO - , _shaderTextures :: [TO] } newtype FBO = FBO {_unFBO :: GLuint} diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index afddf28fa..47ad5f8fd 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -10,7 +10,7 @@ module Shader.Poke ( import Geometry.Vector import Dodge.Data.Wall -import Shader.Poke.Triangulate +import Geometry.Triangulate import Control.Monad.Primitive import qualified Data.Vector as V 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.generate 10 $ - UV.fromList . concatMap triangulate . boxSurfaces' . (+ 3) + UV.fromList . concatMap polyToTris . boxSurfaces' . (+ 3) memoTopPrismIndices :: V.Vector (UV.Vector Int) {-# INLINE memoTopPrismIndices #-} @@ -313,8 +313,8 @@ boxEdgeIndices n = concatMap f [0 .. n -1] cylinderIndices :: Int -> [Int] cylinderIndices n = cylinderRoundIndices n - ++ triangulate [2 * n, 2 * n + 2 .. 4 * n - 1] - ++ triangulate [2 * n + 1, 2 * n + 3 .. 4 * n - 1] + ++ polyToTris [2 * n, 2 * n + 2 .. 4 * n - 1] + ++ polyToTris [2 * n + 1, 2 * n + 3 .. 4 * n - 1] cylinderRoundIndices :: Int -> [Int] cylinderRoundIndices n = diff --git a/src/Shader/Poke/Floor.hs b/src/Shader/Poke/Floor.hs index 5b17917a2..0044e6396 100644 --- a/src/Shader/Poke/Floor.hs +++ b/src/Shader/Poke/Floor.hs @@ -1,22 +1,21 @@ -module Shader.Poke.Floor - ( pokeTile - ) where +module Shader.Poke.Floor ( + pokeTile, +) where -import Geometry -import Shader.Poke.Triangulate import Control.Monad -import Tile import Data.Tile import Foreign +import Geometry +import Tile pokeTile :: Ptr Float -> Int -> Tile -> IO Int -pokeTile ptr i t@Tile { _tilePoly = ps } = do - foldM (pokeTileVerx ttan (_tileArrayZ t) ptr) i $ triangulate $ zip ps (tileTexCoords t) +pokeTile ptr i t@Tile{_tilePoly = ps} = do + foldM (pokeTileVerx ttan (_tileArrayZ t) ptr) i $ polyToTris $ zip ps (tileTexCoords t) where ttan = _tileTangentPos t - _tileZero t -pokeTileVerx :: Point2 -> Float -> Ptr Float -> Int -> (Point2,Point2) -> IO Int -pokeTileVerx tangent tilez ptr i (V2 x y,V2 s t) = do +pokeTileVerx :: Point2 -> Float -> Ptr Float -> Int -> (Point2, Point2) -> IO Int +pokeTileVerx tangent tilez ptr i (V2 x y, V2 s t) = do let a = argV tangent - zipWithM_ (\off -> pokeElemOff ptr (i*8 + off)) [0..] [x,y,1,1,s,t,tilez,a] + zipWithM_ (\off -> pokeElemOff ptr (i * 8 + off)) [0 ..] [x, y, 1, 1, s, t, tilez, a] return $ i + 1 diff --git a/src/Shader/Poke/Triangulate.hs b/src/Shader/Poke/Triangulate.hs deleted file mode 100644 index cd40ec370..000000000 --- a/src/Shader/Poke/Triangulate.hs +++ /dev/null @@ -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] diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index 359618649..4596c1621 100644 --- a/src/ShapePicture.hs +++ b/src/ShapePicture.hs @@ -2,7 +2,7 @@ module ShapePicture ( module ShapePicture.Data , translateSP - , translateSPf + , translateSPxy , translateSPz , rotateSP , noPic @@ -42,13 +42,13 @@ overPosSP :: (Point3 -> Point3) -> SPic -> SPic {-# INLINE overPosSP #-} overPosSP f = bimap (overPosSH f) (picMap $ overPos f) -translateSPf :: Float -> Float -> SPic -> SPic -{-# INLINE translateSPf #-} -translateSPf x y = bimap (translateSH (V3 x y 0)) (translate x y) +translateSPxy :: Float -> Float -> SPic -> SPic +{-# INLINE translateSPxy #-} +translateSPxy x y = translateSP (V3 x y 0) translateSPz :: Float -> SPic -> SPic {-# 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 {-# INLINE translateSP #-}