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

Remove RenderType datatype

Browse Source
This commit is contained in:
jgk
2021-07-30 11:53:51 +02:00
parent c67feb485f
commit 834464db51
31 changed files with 164 additions and 227 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1 -1
View File
@@ -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
src/Dodge/Layout.hs
+1 -1
View File
@@ -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]
src/Dodge/Layout/Tree/Shift.hs
+1 -1
View File
@@ -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)
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -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
src/Dodge/LevelGen/StaticWalls.hs
+1 -1
View File
@@ -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
src/Dodge/LevelGen/Switch.hs
+1 -1
View File
@@ -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
src/Dodge/Picture.hs
+1 -1
View File
@@ -5,7 +5,7 @@ module Dodge.Picture
where
import Geometry
import Geometry.Vector3D
import Geometry.Data
--import Geometry.Data
import Picture
src/Dodge/RandomHelp.hs
+1 -1
View File
@@ -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
src/Dodge/Render.hs
+2 -3
View File
@@ -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
src/Dodge/Render/MenuScreen.hs
+1 -1
View File
@@ -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
src/Dodge/Render/Picture.hs
+1 -20
View File
@@ -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
src/Dodge/Room.hs
+1 -1
View File
@@ -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
src/Dodge/Room/Corridor.hs
+1 -1
View File
@@ -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
src/Dodge/Room/Foreground.hs
+1 -1
View File
@@ -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
src/Dodge/Room/Link.hs
+1 -1
View File
@@ -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
src/FoldableHelp.hs
+14
View File
@@ -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
src/Geometry.hs
+2 -2
View File
@@ -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
src/Geometry/Data.hs
+4
View File
@@ -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
src/Geometry/Vector.hs
+6 -6
View File
@@ -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 (-.-) #-}
src/MatrixHelper.hs
+1 -3
View File
@@ -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
src/Picture.hs
+1 -4
View File
@@ -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
src/Picture/Data.hs
+8 -75
View File
@@ -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]
src/Picture/Texture.hs
-18
View File
@@ -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
src/Polyhedra.hs
+1 -8
View File
@@ -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
src/Preload/Render.hs
+15 -52
View File
@@ -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
src/Shader/Compile.hs
+4 -11
View File
@@ -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 = []
src/Shader/Data.hs
-6
View File
@@ -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]
src/Shader/Poke.hs
+21 -2
View File
@@ -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
src/StrictHelp.hs
+12
View File
@@ -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 ()
src/Tile.hs
+3 -4
View File
@@ -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
src/TreeExtra.hs
+56
View File
@@ -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)