diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 6af7510fe..eb2273f58 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -49,7 +49,6 @@ doDrawing pdata w = do (wallPointsCol,windowPoints) = wallsAndWindows w lightPoints = lightsForGloom w viewFroms = _cameraViewFrom w - pic = worldPictures w -- bind as much data into vbos as feasible at this point -- poke wall points and colors nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol @@ -79,7 +78,7 @@ doDrawing pdata w = do _ <- renderFoldable pdata $ polysToPic $ foregroundPics w - vnums <- pokeBindFoldableLayer pdata pic + vnums <- pokeBindFoldableLayer pdata $ worldPictures w let shads = _pictureShaders pdata renderLayer 0 shads vnums diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 92f4b7971..b5ed29378 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -21,9 +21,12 @@ import Data.List (partition) import qualified Data.IntMap.Lazy as IM worldPictures :: World -> Picture -worldPictures w = - concat (IM.elems $ _decorations w) ++ testPic w ++ concat - [ concatMap (dbArg _pjDraw) . IM.elems $ _projectiles w +worldPictures w = concat $ + (IM.elems $ _decorations w) ++ + (map (dbArg _pjDraw) . IM.elems $ _projectiles w) ++ + (map (crDraw w) . IM.elems $ _creatures w) ++ + (map (dbArg _ptDraw) $ _particles w) ++ + [ testPic w , concatMap drawItem . IM.elems $ _floorItems w , concatMap (crDraw w) . IM.elems $ _creatures w , concatMap clDraw . reverse $ _clouds w diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index 36c2c493a..e23bbbc52 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -72,14 +72,14 @@ makeExplosionAt p w . explosionFlashAt p $ makeShockwaveAt [] p 50 10 1 white w where - fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w - fPs'' = replicateM 75 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w + fVs = replicateM 15 (randInCirc 1) & evalState $ _randGen w + fPs'' = replicateM 15 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w (fPs',zs) = let (a,b,c) = unzip3 $ map fromV3 fPs'' in (zipWith V2 a b, c) fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) fPs' inversePushOut v = (15 - magV v) * 0.01 *.* v fVs' = zipWith (+.+) fVs $ map inversePushOut fPs' - sizes = randomRs (2,6) $ _randGen w + sizes = randomRs (2,9) $ _randGen w times = randomRs (20,25) $ _randGen w mF q z v size time = makeFlameletTimed q z v Nothing size time newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times diff --git a/src/Picture.hs b/src/Picture.hs index 12f8c7d36..80df03838 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -63,7 +63,7 @@ import Picture.Data --import Data.Bifunctor --import qualified Data.DList as DL --import Graphics.Rendering.OpenGL (lineWidth, ($=)) -import Control.Lens +--import Control.Lens blank :: Picture {-# INLINE blank #-} @@ -160,17 +160,16 @@ translate3 :: Float -> Float -> Point3 -> Point3 translate3 !a !b !(V3 x y z) = V3 (x+a) (y+b) z translate :: Float -> Float -> Picture -> Picture ---{-# INLINE translate #-} ---translate x y = map $ second $ overPos (translate3 x y) +{-# INLINE translate #-} translate !x !y = map $! overPos $! translate3 x y setDepth :: Float -> Picture -> Picture ---{-# INLINE setDepth #-} +{-# INLINE setDepth #-} --setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d)) setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d) addDepth :: Float -> Picture -> Picture ---{-# INLINE addDepth #-} +{-# INLINE addDepth #-} --addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d)) addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d)) @@ -185,12 +184,12 @@ scale3 :: Float -> Float -> Point3 -> Point3 scale3 a b (V3 x y z) = (V3 (x*a) (y*b) (z)) scale :: Float -> Float -> Picture -> Picture ---{-# INLINE scale #-} +{-# INLINE scale #-} --scale x y = map . second . overPos $ scale3 x y scale x y = map $ overPos $ scale3 x y rotate :: Float -> Picture -> Picture ---{-# INLINE rotate #-} +{-# INLINE rotate #-} rotate a = map $ overPos $ rotate3 a pictures :: [Picture] -> Picture @@ -230,12 +229,10 @@ text s = map f $ stringToList s line :: [Point2] -> Picture {-# INLINE line #-} ---line = Line line = flip thickLine 1 lineCol :: [(Point2,RGBA)] -> Picture {-# INLINE lineCol #-} ---lineCol = LineCol lineCol = flip thickLineCol 1 thickLine :: [Point2] -> Float -> Picture @@ -296,6 +293,7 @@ thickArc startA endA rad wdth w = 1 - wdth / r thickArcHelp :: Float -> Float -> Float -> Float -> [Verx] +{-# INLINE thickArcHelp #-} thickArcHelp startA endA rad wdth = map f [( (V3 0 0 0),black,(V3 0 0 wdth)) ,((V3 xa ya 0),black,(V3 1 0 wdth)) @@ -330,9 +328,23 @@ chartreuse= V4 0.5 1 0 1 orange = V4 1 0.5 0 1 white = V4 1 1 1 1 black = V4 0 0 0 1 - +{-# INLINE red #-} +{-# INLINE green #-} +{-# INLINE blue #-} +{-# INLINE yellow #-} +{-# INLINE cyan #-} +{-# INLINE magenta #-} +{-# INLINE rose #-} +{-# INLINE violet #-} +{-# INLINE azure #-} +{-# INLINE aquamarine #-} +{-# INLINE chartreuse #-} +{-# INLINE orange #-} +{-# INLINE white #-} +{-# INLINE black #-} mixColors :: Float -> Float -> Color -> Color -> Color +{-# INLINE mixColors #-} mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = let fullrat = rata + ratb normrata = rata / fullrat @@ -341,26 +353,33 @@ mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = in (V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2)) light :: Color -> Color +{-# INLINE light #-} light (V4 r g b a) = (V4 (r+0.2) (g+0.2) (b+0.2) (a)) dark :: Color -> Color +{-# INLINE dark #-} dark (V4 r g b a) = (V4 (r-0.2) (g-0.2) (b-0.2) (a)) dim :: Color -> Color +{-# INLINE dim #-} dim (V4 r g b a) = (V4 (r/1.2) (g/1.2) (b/1.2) (a)) bright :: Color -> Color +{-# INLINE bright #-} bright (V4 r g b a) = (V4 (r*1.2) (g*1.2) (b*1.2) (a)) greyN :: Float -> Color +{-# INLINE greyN #-} greyN x = toV4 (x,x,x,1) overPos :: (Point3 -> Point3) -> Verx -> Verx {-# INLINE overPos #-} -overPos = over vxPos +--overPos = over vxPos +overPos f vx = vx {_vxPos = f (_vxPos vx)} overCol :: (Point4 -> Point4) -> Verx -> Verx -overCol = over vxCol +{-# INLINE overCol #-} +overCol f vx = vx {_vxCol = f (_vxCol vx)} -- no premature optimisation, consider changing to use texture arrays stringToList :: String -> [(Point3,Point4,Point2)] diff --git a/src/Render.hs b/src/Render.hs index a70576b63..78233e04c 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -157,15 +157,21 @@ pokeBindFoldable pdata m = do zeroCounts :: PicShads Int zeroCounts = PicShads 0 0 0 0 0 0 -pokeBindFoldableLayer --- :: Foldable f - :: RenderData +pokeVerxLayers + :: PicShads VBO -> [Verx] + -> Layers (PicShads Int) + -> IO (Layers (PicShads Int)) +pokeVerxLayers = undefined + +pokeBindFoldableLayer + :: RenderData + -> Picture -> IO (Layers (PicShads Int)) pokeBindFoldableLayer pdata m = do let shads = _pictureShaders pdata - slist'' <- pokeLayVerxs (fmap (_vaoVBO . _vshaderVAO) shads) m + slist'' <- pokeLayVerxsPart (fmap (_vaoVBO . _vshaderVAO) shads) m (pure $ pure 0) bindShaderLay shads slist'' return slist'' diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index 817d95474..12e963165 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -37,6 +37,8 @@ module Shader.Data -- TODO make lenses for VBO object -- , textureObject ) where +--import Geometry.Data + import Graphics.Rendering.OpenGL import Foreign import Control.Lens @@ -139,6 +141,14 @@ data FullShader = FullShader {- | Datatype containing the reference to a texture object. -} newtype ShaderTexture = ShaderTexture { _textureObject :: TextureObject } +--data PicVerxs = PicVerxs +-- { _pvPoly :: (Point3,Point4) +-- , _pvPolyz :: (Point3,Point4,Float) +-- , _pvBez :: (Point3,Point4,Point4) +-- , _pvText :: (Point3,Point4,Point2) +-- , _pvArc :: (Point3,Point3,Point3) +-- , _pvEll :: (Point3,Point4) +-- } data EPrimitiveMode = EPoints diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 0253914b0..f7b7c6680 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -7,6 +7,8 @@ module Shader.Poke , pokePoint33s , pokeVerxs , pokeLayVerxs + , pokeLayVerxsPart + , pokeLayVerxsPartM , pokeLayVerxsM , poke224s ) where @@ -22,7 +24,7 @@ import Foreign import Control.Monad --import qualified Control.Foldl as F --import qualified Data.IntMap.Strict as IM -import Control.Lens +--import Control.Lens pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int) pokeVerxs vbos vxs0 = go vxs0 (pure 0) @@ -32,7 +34,7 @@ pokeVerxs vbos vxs0 = go vxs0 (pure 0) -- this is very brittle, but want to optimise speed if possible here pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO () ---{-# INLINE pokeVerx #-} +{-# INLINE pokeVerx #-} pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) (_psPoly offsets * 7 * floatSize)) thePos theCol PolyzV x -> poke34 thePtr thePos theCol @@ -124,6 +126,17 @@ pokeLayVerxsM !vbos = foldM f (pure $ pure 0) where f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx) +pokeLayVerxsPartM :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int)) +pokeLayVerxsPartM !vbos vxs0 count0 = foldM f count0 vxs0 + where + f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx) + +pokeLayVerxsPart :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int)) +pokeLayVerxsPart !vbos vxs0 count0 = go vxs0 count0 + where + go [] count = return count + go (!vx:vxs) !count = pokeLayVerx vbos count vx >> (go vxs $! addLayCountVerx count vx) + pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int)) pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0)) where @@ -132,7 +145,7 @@ pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0)) -- this is very brittle, but want to optimise speed if possible here pokeLayVerx :: PicShads VBO -> Layers (PicShads Int) -> Verx -> IO () ---{-# INLINE pokeLayVerx #-} +{-# INLINE pokeLayVerx #-} pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vxLayer = theLay} = case theType of PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) ((_psPoly offsets + layOff) * 7 * floatSize)) thePos theCol PolyzV x -> poke34 thePtr thePos theCol @@ -164,13 +177,21 @@ pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vx addLayCountVerx :: Layers (PicShads Int) -> Verx -> Layers (PicShads Int) --{-# INLINE addLayCountVerx #-} -addLayCountVerx !m !vx = case _vxLayer vx of - 0 -> m & lay0 %~ f - 1 -> m & lay1 %~ f - 2 -> m & lay2 %~ f - 3 -> m & lay3 %~ f - 4 -> m & lay4 %~ f - 5 -> m & lay5 %~ f +addLayCountVerx !m@Layers + { _lay0 = a0 + , _lay1 = a1 + , _lay2 = a2 + , _lay3 = a3 + , _lay4 = a4 + , _lay5 = a5 + } + !vx = case _vxLayer vx of + 0 -> m { _lay0 = f a0 } + 1 -> m { _lay1 = f a1 } + 2 -> m { _lay2 = f a2 } + 3 -> m { _lay3 = f a3 } + 4 -> m { _lay4 = f a4 } + 5 -> m { _lay5 = f a5 } _ -> undefined where f = flip addCountVerx vx