diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index e8b6d23bc..3731fd5b1 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -65,7 +65,7 @@ data World = World , _wallsZone :: IM.IntMap (IM.IntMap (IM.IntMap Wall)) , _forceFields :: IM.IntMap ForceField , _floorItems :: IM.IntMap FloorItem - , _floorTiles :: [RenderType] + , _floorTiles :: [(Point3,Point3)] , _randGen :: StdGen , _mousePos :: !Point2 , _testString :: String diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index cc093eb66..fc0d5b92c 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -123,7 +123,7 @@ wallsFromRooms = where f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i} -floorsFromRooms :: [Room] -> [RenderType] +floorsFromRooms :: [Room] -> [(Point3,Point3)] floorsFromRooms = concatMap (concatMap tToRender . _rmFloor) divideWall :: Wall -> [Wall] diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index bf8c7b5b9..cda74cafa 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -9,7 +9,7 @@ import Dodge.Room.Data import Dodge.Room.Link import Dodge.Layout.Tree.Polymorphic import Geometry -import Geometry.Data +--import Geometry.Data import Data.Tree import Data.Sequence hiding (zipWith) diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 0f60a6bb3..752bbb7c0 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -19,7 +19,7 @@ import Dodge.LevelGen.TriggerDoor import Dodge.LevelGen.Switch import Dodge.LevelGen.Data import Geometry -import Geometry.Data +--import Geometry.Data import Picture import Polyhedra import qualified IntMapHelp as IM diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 8e40f8ab5..58356646f 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -6,7 +6,7 @@ module Dodge.LevelGen.StaticWalls where import Dodge.Data import Geometry -import Geometry.Data +--import Geometry.Data import FoldableHelp --import Control.Lens diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index a24a911bf..25bfc50e8 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/src/Dodge/LevelGen/Switch.hs @@ -5,7 +5,7 @@ import Dodge.SoundLogic import Dodge.Picture.Layer import Picture import Geometry -import Geometry.Data +--import Geometry.Data import qualified Data.IntMap.Strict as IM import Control.Lens diff --git a/src/Dodge/Picture.hs b/src/Dodge/Picture.hs index d3ce87168..8a372f565 100644 --- a/src/Dodge/Picture.hs +++ b/src/Dodge/Picture.hs @@ -5,7 +5,7 @@ module Dodge.Picture where import Geometry import Geometry.Vector3D -import Geometry.Data +--import Geometry.Data import Picture diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 4c211fd69..308665f54 100644 --- a/src/Dodge/RandomHelp.hs +++ b/src/Dodge/RandomHelp.hs @@ -4,7 +4,7 @@ Helpers for random generation. module Dodge.RandomHelp where import Geometry import Geometry.Vector3D -import Geometry.Data +--import Geometry.Data import System.Random import Control.Monad.State diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index b6df6046a..f67435e92 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -12,11 +12,10 @@ import Dodge.Base.Window import Dodge.Render.Picture --import Dodge.Render.PerspectiveMatrix import Geometry -import Geometry.Data +--import Geometry.Data --import Picture import Render import Data.Preload.Render -import Picture.Data import Shader import Shader.Poke import Shader.Data @@ -90,7 +89,7 @@ doDrawing pdata w = do let shads = _pictureShaders pdata renderLayer 0 shads vnums - nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (map _unRender3x3 $ _floorTiles w) + nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w) bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs] drawShader (_textureArrayShader pdata) nTextArrayVs diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index bd719fb22..086b9965c 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -11,7 +11,7 @@ import Dodge.Config.Data --import Dodge.Base (halfWidth,halfHeight) import Picture import Geometry -import Geometry.Data +--import Geometry.Data menuScreen :: Configuration diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index a367f6f2f..92f4b7971 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -9,7 +9,7 @@ import Dodge.Picture.Layer import Dodge.Render.HUD import Dodge.Render.MenuScreen import Geometry -import Geometry.Data +--import Geometry.Data import Picture import Polyhedra.Data @@ -19,8 +19,6 @@ import Control.Lens import Data.Maybe import Data.List (partition) import qualified Data.IntMap.Lazy as IM -import Foreign.Ptr -import Foreign.Storable worldPictures :: World -> Picture worldPictures w = @@ -215,23 +213,6 @@ wallsToList :: [((Point2,Point2),Point4)] -> [Float] wallsToList = concatMap (\(((V2 a b),(V2 c d)),(V4 e f g h)) -> [a,b,c,d,e,f,g,h]) -pokeWalls :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int -pokeWalls ptr vals0 = go vals0 0 - where - go [] n = return n - go ( (((V2 a b),(V2 c d)),(V4 e f g h)):vals) n = do - pokeElemOff ptr (off 0) a - pokeElemOff ptr (off 1) b - pokeElemOff ptr (off 2) c - pokeElemOff ptr (off 3) d - pokeElemOff ptr (off 4) e - pokeElemOff ptr (off 5) f - pokeElemOff ptr (off 6) g - pokeElemOff ptr (off 7) h - go vals (n+1) - where - off i = n*8 + i - lightsForGloom :: World -> [(Point3,Float,Float)] lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w) where diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index f3053e10a..c0ce8422d 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -33,7 +33,7 @@ import Dodge.Room.Door import Dodge.Room.Airlock import Dodge.Room.LongDoor import Geometry -import Geometry.Data +--import Geometry.Data import Picture import Tile diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index f527a819f..b0de5d0f4 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -3,7 +3,7 @@ module Dodge.Room.Corridor import Dodge.Room.Data import Dodge.Default.Room import Geometry -import Geometry.Data +--import Geometry.Data import Tile import Data.Bifunctor diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 8f813a0ec..1bb19a2b0 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -5,7 +5,7 @@ import Dodge.Picture import Dodge.Base import Picture import Geometry -import Geometry.Data +--import Geometry.Data import Geometry.Vector3D import Polyhedra import Polyhedra.Data diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index dff093ff3..562ffb400 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -12,7 +12,7 @@ import Dodge.LevelGen.Data import Dodge.Room.Data import Dodge.RandomHelp import Geometry -import Geometry.Data +--import Geometry.Data import Data.Tile import System.Random diff --git a/src/FoldableHelp.hs b/src/FoldableHelp.hs new file mode 100644 index 000000000..2ff9ad7f0 --- /dev/null +++ b/src/FoldableHelp.hs @@ -0,0 +1,14 @@ +module FoldableHelp + ( safeMinimumOn + , module Data.Foldable + ) + where +import Data.Foldable + +safeMinimumOn :: (Foldable t,Ord b) => (a -> b) -> t a -> Maybe a +safeMinimumOn f = foldl' g Nothing + where + g (Just x) y + | f x < f y = Just x + | otherwise = Just y + g Nothing y = Just y diff --git a/src/Geometry.hs b/src/Geometry.hs index 62192cd38..b53f846d5 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -53,13 +53,13 @@ closestPointOnLineParam !a !b !p = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a) -- | Draw a rectangle based on maximal N E S W values. rectNESW :: Float -> Float -> Float -> Float -> [Point2] -rectNESW !a !b !c !d = [(V2 b a),(V2 b c),(V2 d c),(V2 d a) ] +rectNESW !a !b !c !d = [V2 b a,V2 b c,V2 d c,V2 d a] -- | Draw a rectangle based on maximal N S E W values. rectNSEW :: Float -> Float -> Float -> Float -> [Point2] rectNSEW !n !s !e !w = rectNESW n e s w -- | Draw a rectangle based on maximal N S W E values. rectNSWE :: Float -> Float -> Float -> Float -> [Point2] -rectNSWE !n !s !w !e = [ (V2 w n), (V2 w s), (V2 e s), (V2 e n)] +rectNSWE !n !s !w !e = [V2 w n, V2 w s, V2 e s, V2 e n] -- | Draw a rectangle around the origin with given height and width rectWdthHght :: Float -> Float -> [Point2] rectWdthHght w h = rectNSWE h (-h) (-w) w diff --git a/src/Geometry/Data.hs b/src/Geometry/Data.hs index 45e5acf32..7e03194f4 100644 --- a/src/Geometry/Data.hs +++ b/src/Geometry/Data.hs @@ -21,10 +21,14 @@ type Point2 = V2 Float type Point3 = V3 Float type Point4 = V4 Float +toV2 :: (a,a) -> V2 a toV2 (a,b) = V2 a b +toV3 :: (a,a,a) -> V3 a toV3 (a,b,c) = V3 a b c +toV4 :: (a,a,a,a) -> V4 a toV4 (a,b,c,d) = V4 a b c d +fromV3 :: V3 a -> (a,a,a) fromV3 (V3 a b c) = (a,b,c) uncurryV :: (a -> a -> b) -> V2 a -> b diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index f873cb3b1..783fc0583 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -13,12 +13,12 @@ infixl 7 *.* {- | 2D coordinate-wise addition. -} (+.+) :: Point2 -> Point2 -> Point2 {-# INLINE (+.+) #-} -(+.+) = (+) ---(x1, y1) +.+ (x2, y2) = --- let --- !x = x1 + x2 --- !y = y1 + y2 --- in (x, y) +--(+.+) = -- (+) +V2 x1 y1 +.+ V2 x2 y2 = + let + !x = x1 + x2 + !y = y1 + y2 + in V2 x y {- | 2D coordinate-wise subtraction. -} (-.-) :: Point2 -> Point2 -> Point2 {-# INLINE (-.-) #-} diff --git a/src/MatrixHelper.hs b/src/MatrixHelper.hs index 77d841254..78191b900 100644 --- a/src/MatrixHelper.hs +++ b/src/MatrixHelper.hs @@ -6,7 +6,7 @@ module MatrixHelper import Geometry.Data import Linear.Matrix -import Linear.V4 +--import Linear.V4 import Graphics.Rendering.OpenGL (GLfloat) perspectiveMatrixb @@ -21,14 +21,12 @@ perspectiveMatrixb rot zoom (V2 tranx trany) (V2 winx winy) (V2 viewFromx viewFr . vToL . lmt $ scaleMat (V2 (2*zoom/winx) (2*zoom/winy)) - -- $ scaleMat (2/winx,2/winy) !*! rotMatr (-rot) !*! transMat (V2 (viewFromx-tranx) (viewFromy-trany)) !*! perMat (zoom * 0.4) !*! transMat (V2 (-viewFromx) (-viewFromy)) !*! vertScale !*! vertTrans 20 - -- !*! vertTrans 80 isoMatrix :: Float -- ^ Rotation diff --git a/src/Picture.hs b/src/Picture.hs index 2041523b1..8a285de95 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -53,7 +53,7 @@ module Picture where import Geometry import Geometry.Vector3D -import Geometry.Data +--import Geometry.Data import Picture.Data --import Data.List @@ -65,9 +65,6 @@ import Control.Lens black :: RGBA black = (V4 0 0 0 1) ---zl :: RenderType -> [(Int,RenderType)] ---zl rt = [(0,rt)] - polygon :: [Point2] -> Picture {-# INLINE polygon #-} polygon ps = map (f . zeroZ) $ polyToTris ps diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index c8796ea27..57d467a0c 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -19,89 +19,22 @@ import Control.Lens --import Control.Monad data Verx = Verx - { _vxPos :: Point3 - , _vxCol :: Point4 - , _vxType :: VertexType - , _vxLayer :: Int + { _vxPos :: !Point3 + , _vxCol :: !Point4 + , _vxType :: !VertexType + , _vxLayer :: !Int } data VertexType = PolyV - | PolyzV Float - | BezV Point4 - | TextV Point2 - | ArcV Point3 + | PolyzV !Float + | BezV !Point4 + | TextV !Point2 + | ArcV !Point3 | EllV -data RenderType - -- -= RenderPoly [(Point3,Point4)] - -- -| RenderPolyZ [(Point3,Point4,Float)] - -- -| RenderBezQ [(Point3,Point4,Point4)] - -- -| RenderText [(Point3,Point4,Point2)] - -- -| RenderArc [(Point3,Point4,Point3)] - -- -| RenderEllipse [(Point3,Point4)] - = Render3 [Point3] - | Render1111 {_unRender1111 :: (Float,Float,Float,Float)} - | Render22 {_unRender22 :: (Point2,Point2)} - | Render2221 {_unRender2221 :: (Point2,Point2,Point2,Float)} - | Render22x4 {_unRender22x4 :: ((Point2,Point2),Point4)} - | Render3x2 {_unRender3x2 :: (Point3,Point2)} - | Render3x3 {_unRender3x3 :: (Point3,Point3)} - deriving Generic -instance NFData RenderType - type RGBA = Point4 type Color = Point4 -data FTree a - = FBranch (a -> a) (FTree a) - | FBranches [FTree a] - | FLeaf a -instance Foldable FTree where - foldMap g (FBranch f t) = foldMap (g . f) t - foldMap g (FBranches ts) = mconcat $ map (foldMap g) ts - foldMap g (FLeaf x) = g x - {-# INLINE foldMap #-} -instance Functor FTree where - fmap g (FBranch f t) = fmap (g . f) t - fmap f (FBranches ts) = FBranches $ fmap (fmap f) ts - fmap f (FLeaf x) = FLeaf (f x) - {-# INLINE fmap #-} - -{- Tree with values at and only at the leaves. -} -data LTree a - = LBranches [LTree a] - | LLeaf a - deriving (Generic) -instance NFData a => NFData (LTree a) -instance Foldable LTree where - foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts - foldMap g (LLeaf a) = g a - {-# INLINE foldMap #-} - foldr _ x (LBranches []) = x - --foldr g x (LBranches (t:ts)) = foldr g x t `seq` foldr g (foldr g x t) (LBranches ts) - foldr g x (LBranches (t:ts)) = foldr g (foldr g x t) (LBranches ts) - --foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t - foldr g x (LLeaf y) = g y x - {-# INLINE foldr #-} - foldl' _ x (LBranches []) = x - foldl' g x (LBranches (t:ts)) = foldl' g x t `seq` foldl' g (foldl' g x t) (LBranches ts) - foldl' g x (LLeaf y) = g x y - {-# INLINE foldl' #-} -instance Functor LTree where - fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts - fmap f (LLeaf x) = LLeaf (f x) - {-# INLINE fmap #-} - -data RTree a b - = RBranches a [RTree a b] - | RLeaf b -instance Foldable (RTree a) where - foldMap g (RBranches _ ts) = mconcat $ map (foldMap g) ts - foldMap g (RLeaf x) = g x - {-# INLINE foldMap #-} -instance Functor (RTree a) where - fmap f (RBranches i ts) = RBranches i $ fmap (fmap f) ts - fmap f (RLeaf x) = RLeaf (f x) flat2 :: V2 a -> [a] flat2 (V2 x y) = [x,y] diff --git a/src/Picture/Texture.hs b/src/Picture/Texture.hs deleted file mode 100644 index 117dbfb5f..000000000 --- a/src/Picture/Texture.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Picture.Texture - where -import Geometry.Data ---import Geometry -import Picture.Data ---import Data.Tile - -tileToRender :: [Point3] -> [Point3] -> [RenderType] -tileToRender [a,b,c,d] [x,y,z,w] = - [ Render3x3 (x,a) - , Render3x3 (y,b) - , Render3x3 (z,c) - , Render3x3 (x,a) - , Render3x3 (z,c) - , Render3x3 (w,d) - ] -tileToRender _ _ = undefined - diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index 53d84378f..c886f364b 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -1,7 +1,7 @@ module Polyhedra where import Geometry -import Geometry.Data +--import Geometry.Data import Geometry.Vector3D import Polyhedra.Data import Picture.Data @@ -96,12 +96,5 @@ polysToPic = pictures . concatMap polyToPics polyToEdges :: Polyhedra -> [(Point3,Point3,Point3,Point3)] polyToEdges = constructEdges . map (map fst) . _pyFaces --- rendering for silhouette -polyToRender :: Polyhedra -> [RenderType] -polyToRender = map (Render3 . tflat4) . polyToEdges --- rendering for shape -polyToGeoRender :: Polyhedra -> [RenderType] -polyToGeoRender = map (Render3 . polyToTris . map fst) . _pyFaces - polyToGeoRender' :: Polyhedra -> [Point3] polyToGeoRender' = concatMap (polyToTris . map fst) . _pyFaces diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 818d2ec4a..0616df3b6 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -5,14 +5,12 @@ module Preload.Render , cleanUpRenderPreload ) where -import Picture.Data import Shader import Shader.Data import Shader.Compile import Shader.AuxAddition import Shader.Parameters import Data.Preload.Render -import Geometry.Data import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Graphics.GL.Core43 @@ -52,45 +50,44 @@ preloadRender = do wpColVAO = VAO {_vao = wpColVAOname, _vaoVBO = wpVBO} -- lighting shaders - wsShad <- makeShader "lighting/occlude" [vert,geom,frag] [4] EPoints pokeWPStrat + wsShad <- makeShader "lighting/occlude" [vert,geom,frag] [4] EPoints >>= addUniforms ["lightPos"] wlLightShad <- makeShaderUsingShaderVAO "lighting/wall" [vert,geom,frag] EPoints wsShad >>= addUniforms ["lightPos","radLum"] lightingSurfaceShad - <- makeShader "lighting/surface" [vert,frag] [3] ETriangles poke3 + <- makeShader "lighting/surface" [vert,frag] [3] ETriangles >>= addUniforms ["lightPos","radLum"] lightingLineShadowShad - <- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency poke3 + <- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency >>= addUniforms ["lightPos"] -- 2D draw shaders - bslist <- makeVShader "twoD/basic" [vert,frag] [3,4] ETriangles isPolyV - aslist <- makeVShader "twoD/arc" [vert,frag] [3,4,3] ETriangles isArcV - eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles isEllV - bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip isBezV - cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles isTextV + bslist <- makeVShader "twoD/basic" [vert,frag] [3,4] ETriangles + aslist <- makeVShader "twoD/arc" [vert,frag] [3,4,3] ETriangles + eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles + bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip + cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles >>= vaddTextureNoFilter "data/texture/charMap.png" -- this should really be a 2d texture array - basicTweakZShad <- makeVShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles isPolyzV + basicTweakZShad <- makeVShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles -- fullscreen shaders - fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip $ - const cornerListNoCoord + fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord -- texture shaders, no textures attached - fsShad <- makeShaderSized "texture/simple" [vert,frag] [2,2] 4 ETriangleStrip $ const cornerList + fsShad <- makeShaderSized "texture/simple" [vert,frag] [2,2] 4 ETriangleStrip -- note we directly poke the shader vertex data here pokeArray (shadVBOptr fsShad) $ concat cornerList bloomBlurShad <- makeShaderUsingShaderVAO "texture/bloomBlur" [vert,frag] ETriangleStrip fsShad colorBlurShad <- makeShaderUsingShaderVAO "texture/colorBlur" [vert,frag] ETriangleStrip fsShad grayscaleShad <- makeShaderUsingShaderVAO "texture/grayscale" [vert,frag] ETriangleStrip fsShad - barrelShad <- makeShader "texture/barrel" [vert,geom,frag] [2,2,2,1] EPoints pokeRadDist + barrelShad <- makeShader "texture/barrel" [vert,geom,frag] [2,2,2,1] EPoints -- blank wallShader - wlBlank <- makeShader "wall/blank" [vert,geom,frag] [4,4] EPoints pokeWPColStrat + wlBlank <- makeShader "wall/blank" [vert,geom,frag] [4,4] EPoints -- textured wallShader - wlTexture <- makeShader "wall/texture" [vert,geom,frag] [4,4] EPoints pokeWPColStrat + wlTexture <- makeShader "wall/texture" [vert,geom,frag] [4,4] EPoints >>= addTexture "data/texture/grayscaleDirt.png" ---- texture array shader - textArrayShad <- makeShader "texture/array" [vert,frag] [3,3] ETriangles poke33 + textArrayShad <- makeShader "texture/array" [vert,frag] [3,3] ETriangles >>= addTextureArray "data/texture/ayene_wooden_floor.png" -- bind fixed vertex data bindShaderBuffers [fsShad,fullscreenAlphaHalveShad] [4,4] @@ -224,37 +221,3 @@ vert, geom, frag :: ShaderType vert = VertexShader geom = GeometryShader frag = FragmentShader - -poke3 :: RenderType -> [[Float]] -poke3 (Render3 vs) = map flat3 vs -poke3 _ = undefined - -pokeWPStrat :: RenderType -> [[Float]] -pokeWPStrat Render22{_unRender22 = ((V2 x y),(V2 z w))} = [[x,y,z,w]] -pokeWPStrat _ = undefined - -pokeRadDist :: RenderType -> [[Float]] -pokeRadDist Render2221{_unRender2221 = (V2 a b,V2 c d,V2 e f,g)} = [[a,b,c,d,e,f,g]] -pokeRadDist _ = undefined - -pokeWPColStrat :: RenderType -> [[Float]] -pokeWPColStrat Render22x4{_unRender22x4=((V2 x y,V2 z w),V4 r g b a)} = [[x,y,z,w,r,g,b,a]] -pokeWPColStrat _ = undefined - -poke33 :: RenderType -> [[Float]] -poke33 Render3x3{_unRender3x3=(V3 x y z,V3 a b c)} = [[x,y,z,a,b,c]] -poke33 _ = undefined - -isPolyV, isArcV, isEllV, isTextV, isBezV, isPolyzV :: VertexType -> Bool -isPolyV PolyV = True -isPolyV _ = False -isArcV (ArcV _) = True -isArcV _ = False -isEllV EllV = True -isEllV _ = False -isTextV (TextV _) = True -isTextV _ = False -isBezV (BezV _) = True -isBezV _ = False -isPolyzV (PolyzV _) = True -isPolyzV _ = False diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index fecfae4af..9377dc29a 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -9,7 +9,6 @@ module Shader.Compile ) where import Shader.Data import Shader.Parameters -import Picture.Data import Foreign import qualified Data.ByteString as BS @@ -26,9 +25,8 @@ makeVShader -> [ShaderType] -- ^ Filetype extensions -> [Int] -- ^ The input vertex sizes -> EPrimitiveMode - -> (VertexType -> Bool) -> IO VShader -makeVShader s shaderlist sizes renStrat vtest = do +makeVShader s shaderlist sizes pm = do prog <- makeSourcedShader s shaderlist vaob <- setupVAO sizes return $ VShader @@ -36,8 +34,7 @@ makeVShader s shaderlist sizes renStrat vtest = do , _vshaderVAO = vaob , _vshaderTexture = Nothing , _vshaderCustomUnis = [] - , _vshaderPokeTest = vtest - , _vshaderDrawPrimitive = renStrat + , _vshaderDrawPrimitive = pm } -- | Takes the VAO and poke strategy from another shader @@ -64,15 +61,13 @@ makeShader -> [ShaderType] -- ^ Filetype extensions -> [Int] -- ^ The input vertex sizes -> EPrimitiveMode - -> (RenderType -> [[Float]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound -> IO FullShader -makeShader s shaderlist sizes pm renStrat = do +makeShader s shaderlist sizes pm = do prog <- makeSourcedShader s shaderlist vaob <- setupVAO sizes return $ FullShader { _shaderProgram = prog , _shaderVAO = vaob - , _shaderPokeStrategy = renStrat , _shaderDrawPrimitive = pm , _shaderTexture = Nothing , _shaderCustomUnis = [] @@ -87,15 +82,13 @@ makeShaderSized -> [Int] -- ^ The input vertex sizes -> Int -- ^ Number of vertexes that can be poked -> EPrimitiveMode - -> (RenderType -> [[Float]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound -> IO FullShader -makeShaderSized s shaderlist sizes ndraw pm renStrat = do +makeShaderSized s shaderlist sizes ndraw pm = do prog <- makeSourcedShader s shaderlist vaob <- setupVAOSized sizes ndraw return $ FullShader { _shaderProgram = prog , _shaderVAO = vaob - , _shaderPokeStrategy = renStrat , _shaderDrawPrimitive = pm , _shaderTexture = Nothing , _shaderCustomUnis = [] diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index 4c970ca77..388d174ce 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -16,7 +16,6 @@ module Shader.Data , shaderProgram , shaderVAO - , shaderPokeStrategy , shaderDrawPrimitive , shaderTexture , shaderCustomUnis @@ -26,7 +25,6 @@ module Shader.Data , vshaderDrawPrimitive , vshaderTexture , vshaderCustomUnis - , vshaderPokeTest , psPoly , psPolyz @@ -38,8 +36,6 @@ module Shader.Data -- TODO make lenses for VBO object -- , textureObject ) where -import Picture.Data - import Graphics.Rendering.OpenGL import Foreign import Control.Lens @@ -66,7 +62,6 @@ data VShader = VShader , _vshaderDrawPrimitive :: EPrimitiveMode , _vshaderTexture :: Maybe ShaderTexture , _vshaderCustomUnis :: [UniformLocation] - , _vshaderPokeTest :: VertexType -> Bool } data PicShads a = PicShads { _psPoly :: a @@ -136,7 +131,6 @@ instance Foldable PicShads where data FullShader = FullShader { _shaderProgram :: Program , _shaderVAO :: VAO - , _shaderPokeStrategy :: RenderType -> [[Float]]-- -> F.FoldM IO RenderType Int , _shaderDrawPrimitive :: EPrimitiveMode , _shaderTexture :: Maybe ShaderTexture , _shaderCustomUnis :: [UniformLocation] diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 6164ed130..50342daf9 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -8,6 +8,7 @@ module Shader.Poke , pokePoint33s , pokeVerxs , pokeLayVerxs + , pokeWalls ) where import Shader.Data import Shader.Parameters @@ -55,7 +56,7 @@ pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int) pokeVerxs vbos vxs0 = go vxs0 (pure 0) where go [] count = return count - go (!vx:vxs) count = pokeVerx vbos count vx >> go vxs (addCountVerx count vx) + go (!vx:vxs) !count = pokeVerx vbos count vx >> (go vxs $! addCountVerx count vx) -- this is very brittle, but want to optimise speed if possible here pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO () @@ -175,7 +176,7 @@ pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (IM.IntMap (PicShads Int)) pokeLayVerxs vbos vxs0 = go vxs0 (IM.fromList $ (, pure 0) <$> [0..5]) where go [] count = return count - go (!vx:vxs) count = pokeLayVerx vbos count vx >> go vxs (addLayCountVerx count vx) + go (!vx:vxs) !count = pokeLayVerx vbos count vx >> (go vxs $! addLayCountVerx count vx) -- this is very brittle, but want to optimise speed if possible here pokeLayVerx :: PicShads VBO -> IM.IntMap (PicShads Int) -> Verx -> IO () @@ -214,3 +215,21 @@ addLayCountVerx :: IM.IntMap (PicShads Int) -> Verx -> IM.IntMap (PicShads Int) addLayCountVerx m vx = IM.adjust f (_vxLayer vx) m where f = flip addCountVerx vx + +pokeWalls :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int +pokeWalls ptr vals0 = go vals0 0 + where + go [] n = return n + go ((((V2 a b),(V2 c d)),(V4 e f g h)):vals) !n = do + pokeElemOff ptr (off 0) a + pokeElemOff ptr (off 1) b + pokeElemOff ptr (off 2) c + pokeElemOff ptr (off 3) d + pokeElemOff ptr (off 4) e + pokeElemOff ptr (off 5) f + pokeElemOff ptr (off 6) g + pokeElemOff ptr (off 7) h + go vals (n+1) + where + off i = n*8 + i + diff --git a/src/StrictHelp.hs b/src/StrictHelp.hs new file mode 100644 index 000000000..31f5cdf36 --- /dev/null +++ b/src/StrictHelp.hs @@ -0,0 +1,12 @@ +module StrictHelp + where + +{- | In order to force a list, apply with seq. -} +forceSpine :: Foldable t => t a -> () +forceSpine = foldr (const id) () + +forceFoldable :: Foldable t => t a -> t a +forceFoldable f = forceSpine f `seq` f + +forceElements :: Foldable t => t a -> () +forceElements = foldr seq () diff --git a/src/Tile.hs b/src/Tile.hs index f2e4545dc..984910342 100644 --- a/src/Tile.hs +++ b/src/Tile.hs @@ -2,11 +2,10 @@ module Tile where import Data.Tile import Geometry -import Geometry.Data -import Picture.Data +--import Geometry.Data -tToRender :: Tile -> [RenderType] -tToRender t = map Render3x3 $ polyToTris $ zip ps3 coords3 +tToRender :: Tile -> [(Point3,Point3)] +tToRender t = polyToTris $ zip ps3 coords3 where ps = _tilePoly t coords = map (calcTexCoord (_tileCenter t) (_tileX t) (_tileY t)) ps diff --git a/src/TreeExtra.hs b/src/TreeExtra.hs new file mode 100644 index 000000000..b8c1ee5aa --- /dev/null +++ b/src/TreeExtra.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveGeneric #-} +module TreeExtra + where +import GHC.Generics (Generic) +import Control.DeepSeq +import Data.Foldable +data FTree a + = FBranch (a -> a) (FTree a) + | FBranches [FTree a] + | FLeaf a +instance Foldable FTree where + foldMap g (FBranch f t) = foldMap (g . f) t + foldMap g (FBranches ts) = mconcat $ map (foldMap g) ts + foldMap g (FLeaf x) = g x + {-# INLINE foldMap #-} +instance Functor FTree where + fmap g (FBranch f t) = fmap (g . f) t + fmap f (FBranches ts) = FBranches $ fmap (fmap f) ts + fmap f (FLeaf x) = FLeaf (f x) + {-# INLINE fmap #-} + +{- Tree with values at and only at the leaves. -} +data LTree a + = LBranches [LTree a] + | LLeaf a + deriving (Generic) +instance NFData a => NFData (LTree a) +instance Foldable LTree where + foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts + foldMap g (LLeaf a) = g a + {-# INLINE foldMap #-} + foldr _ x (LBranches []) = x + --foldr g x (LBranches (t:ts)) = foldr g x t `seq` foldr g (foldr g x t) (LBranches ts) + foldr g x (LBranches (t:ts)) = foldr g (foldr g x t) (LBranches ts) + --foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t + foldr g x (LLeaf y) = g y x + {-# INLINE foldr #-} + foldl' _ x (LBranches []) = x + foldl' g x (LBranches (t:ts)) = foldl' g x t `seq` foldl' g (foldl' g x t) (LBranches ts) + foldl' g x (LLeaf y) = g x y + {-# INLINE foldl' #-} +instance Functor LTree where + fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts + fmap f (LLeaf x) = LLeaf (f x) + {-# INLINE fmap #-} + +data RTree a b + = RBranches a [RTree a b] + | RLeaf b +instance Foldable (RTree a) where + foldMap g (RBranches _ ts) = mconcat $ map (foldMap g) ts + foldMap g (RLeaf x) = g x + {-# INLINE foldMap #-} +instance Functor (RTree a) where + fmap f (RBranches i ts) = RBranches i $ fmap (fmap f) ts + fmap f (RLeaf x) = RLeaf (f x)