Remove RenderType datatype

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

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]

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)

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

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

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

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
 
 

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

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
 

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 

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 

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
 

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

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

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

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

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

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

src/Geometry/Vector.hs

@@ -13,12 +13,12 @@ infixl 7 *.*
 {- | 2D coordinate-wise addition.  -}
 (+.+) :: Point2 -> Point2 -> Point2
 {-# INLINE (+.+) #-}
-(+.+) = (+)
+--(+.+) = -- (+)
---(x1, y1) +.+ (x2, y2) =
+V2 x1 y1 +.+ V2 x2 y2 =
---  let
+  let
---    !x = x1 + x2
+    !x = x1 + x2
---    !y = y1 + y2
+    !y = y1 + y2
---  in (x, y)
+  in V2 x y 
 {- | 2D coordinate-wise subtraction.  -}
 (-.-) :: Point2 -> Point2 -> Point2
 {-# INLINE (-.-) #-}

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

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

src/Picture/Data.hs

@@ -19,89 +19,22 @@ import Control.Lens
 --import Control.Monad 
 
 data Verx = Verx
-    { _vxPos    :: Point3
+    { _vxPos    :: !Point3
-    , _vxCol    :: Point4
+    , _vxCol    :: !Point4
-    , _vxType   :: VertexType
+    , _vxType   :: !VertexType
-    , _vxLayer  :: Int
+    , _vxLayer  :: !Int
     }
 data VertexType
     = PolyV
-    | PolyzV Float
+    | PolyzV    !Float
-    | BezV Point4
+    | BezV      !Point4
-    | TextV Point2
+    | TextV     !Point2
-    | ArcV Point3
+    | 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

@@ -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,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

@@ -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
+    bslist <- makeVShader "twoD/basic"   [vert,frag] [3,4]   ETriangles 
-    aslist <- makeVShader "twoD/arc"     [vert,frag] [3,4,3] ETriangles isArcV
+    aslist <- makeVShader "twoD/arc"     [vert,frag] [3,4,3] ETriangles 
-    eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4]   ETriangles isEllV
+    eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4]   ETriangles 
-    bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip isBezV
+    bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip
-    cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles isTextV
+    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 $
+    fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip
-        const cornerListNoCoord
     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

@@ -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 = pm
-        , _vshaderDrawPrimitive = renStrat
         }
 
 -- | 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

@@ -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

@@ -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

@@ -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

@@ -2,11 +2,10 @@ module Tile
     where
 import Data.Tile
 import Geometry
-import Geometry.Data
+--import Geometry.Data
-import Picture.Data
 
-tToRender :: Tile -> [RenderType]
+tToRender :: Tile -> [(Point3,Point3)]
-tToRender t = map Render3x3 $ polyToTris $ zip ps3 coords3
+tToRender t = polyToTris $ zip ps3 coords3
   where
     ps = _tilePoly t
     coords = map (calcTexCoord (_tileCenter t) (_tileX t) (_tileY t)) ps

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)