Define shape datatype

src/Color.hs

@@ -0,0 +1,74 @@
+module Color
+  where
+import Geometry
+
+type RGBA  = Point4
+type Color = Point4
+
+withAlpha :: Float -> RGBA -> RGBA
+{-# INLINE withAlpha #-}
+withAlpha a (V4 x y z a') = V4 x y z (a*a')
+
+red,green,blue,yellow,cyan,magenta,rose
+    ,violet,azure,aquamarine,chartreuse,orange,white,black::Color
+red       = V4   1   0   0 1 
+green     = V4   0   1   0 1 
+blue      = V4   0   0   1 1 
+yellow    = V4   1   1   0 1  
+cyan      = V4   0   1   1 1 
+magenta   = V4   1   0   1 1  
+rose      = V4   1   0 0.5 1 
+violet    = V4 0.5   0   1 1  
+azure     = V4   0 0.5   1 1 
+aquamarine= V4   0   1 0.5 1 
+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
+        normratb = ratb / fullrat
+        f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
+    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
+
+brightX :: Float -> Float -> Color -> Color
+{-# INLINE brightX #-}
+brightX cm am (V4 r g b a) = V4 (r*cm) (g*cm) (b*cm) (a*am)
+
+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)

src/Data/Preload/Render.hs

@@ -28,6 +28,7 @@ data RenderData = RenderData
     , _colorBlurShader          :: FullShader
     , _barrelShader             :: FullShader
     , _grayscaleShader          :: FullShader
+    , _shapeShader              :: FullShader
     , _pictureShaders           :: MV.MVector (PrimState IO) FullShader
     , _fbo2                     :: (FramebufferObject, TextureObject)
     , _fbo3                     :: (FramebufferObject, TextureObject)

src/Dodge/Creature/State/Data.hs

@@ -5,8 +5,7 @@ module Dodge.Creature.State.Data
 --import Geometry
 import Geometry.Data
 import Dodge.Data.DamageType
---import Dodge.Creature.Stance.Data
+import Color
-import Picture.Data
 
 import Control.Lens
 import qualified Data.IntSet as IS

src/Dodge/Data.hs

@@ -30,6 +30,7 @@ import Polyhedra.Data
 import Sound.Data
 import qualified DoubleStack as DS
 import Dodge.GameRoom
+import Color
 
 import GHC.Generics
 import Control.Lens

src/Dodge/Item/Weapon/Bezier.hs

@@ -59,7 +59,7 @@ shootBezier targetp cr w = w & particles %~ (theBullet :)
         startp 
         (controlp +.+ randPos) 
         (targetp +.+ randPos')
-        (destroyOnImpact bulHitCr bulHitWall' bulHitFF') 
+        (destroyOnImpact bulHitCr bulHitWall bulHitFF') 
         5
     controlp = mouseWorldPos w
     cid = _crID cr

src/Dodge/Item/Weapon/Bullet.hs

@@ -8,14 +8,14 @@ import Geometry.Data
 basicBullet :: Ammo
 basicBullet = BulletAmmo
     { _amString = "BULLET"
-    , _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF'
+    , _amBulEff = destroyOnImpact bulHitCr bulHitWall bulHitFF'
     , _amBulWth = 2
     , _amBulVel = V2 50 0
     }
 ltBullet :: Ammo
 ltBullet = BulletAmmo
     { _amString = "LTBULLET"
-    , _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF'
+    , _amBulEff = destroyOnImpact bulHitCr bulHitWall bulHitFF'
     , _amBulWth = 2
     , _amBulVel = V2 40 0
     }

src/Dodge/LevelGen/Block.hs

@@ -11,8 +11,8 @@ import Dodge.WorldEvent.Sound
 import Dodge.LevelGen.Pathing
 import Dodge.RandomHelp
 import Geometry
-import Picture.Data
 import qualified IntMapHelp as IM
+import Color
 
 import Control.Lens
 import Control.Monad.State

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -137,10 +137,10 @@ bulConCr' bt p cr w
     ep = sp +.+ _btVel' bt
     mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
 {- | Hitting wall effects: create a spark, damage blocks.  -}
-bulHitWall' :: Particle -> Point2 -> Wall -> World -> World
+bulHitWall :: Particle -> Point2 -> Wall -> World -> World
-bulHitWall' bt p wl w = damageBlocksBy 5 wl
+bulHitWall bt p wl w = damageBlocksBy 5 wl
     . smokeCloudAt dustcol 20 200 1 (addZ 20 pOut)
-    $ createSparkCol 8 theCol pOut (reflectDir wl)
+    . createSparkCol 8 theCol pOut (reflectDir wl)
     $ set randGen g
     w
   where 
@@ -212,8 +212,3 @@ hvBulHitWall' bt p x w =  damageBlocksBy 5 x $ set randGen g $ foldr ($) w (spar
 
 bulHitFF' :: Particle -> Point2 -> ForceField -> World -> World
 bulHitFF' _ _ _ = id
-{- | Typical effect: destroy on impact, damage creatures and blocks, create spark on walls.  -}
-basicBulletEffect :: HitEffect
-basicBulletEffect = destroyOnImpact bulHitCr bulHitWall' bulHitFF'
-
-

src/Dodge/Render.hs

@@ -10,6 +10,7 @@ import Dodge.Base.Window
 import Dodge.Render.Picture
 --import Dodge.Creature.ShadowBox
 import Dodge.Creature.Silhouette
+import Dodge.Render.Shape
 import Geometry
 import Render
 import Data.Preload.Render
@@ -20,7 +21,7 @@ import Shader.Data
 import MatrixHelper
 --import Polyhedra.Data
 import Polyhedra
---import Tuple
+import Shape.Data
 
 import Foreign
 --import Control.Applicative
@@ -88,6 +89,12 @@ doDrawing pdata w = do
     layerCounts <- UMV.replicate (6*6) 0
     pokeBindFoldableLayer shadV layerCounts $ worldPictures w
     renderLayer 0 shadV layerCounts
+
+    numShapeVs <- pokeShapeVs (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) 
+        $ _shVertices $ worldShape w
+    bindShaderBuffers [_shapeShader pdata] [numShapeVs]
+    drawShader (_shapeShader pdata) numShapeVs
+
     --draw floor onto base buffer
     nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
     bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs]

src/Dodge/Render/Shape.hs

@@ -0,0 +1,9 @@
+module Dodge.Render.Shape
+  where
+import Dodge.Data
+import Shape
+import Geometry
+import Color
+
+worldShape :: World -> Shape
+worldShape _ = colorSh green . translateSh (V3 (-20) 200 50) . flatPoly $ rectNSWE 20 0 0 20

src/Picture.hs

@@ -1,8 +1,8 @@
-{-# LANGUAGE TupleSections
+{-# LANGUAGE TupleSections #-}
-  , BangPatterns 
+{-# LANGUAGE BangPatterns  #-}
-  #-}
 module Picture
     ( module Picture.Data
+    , module Color
     , blank
     , polygon
     , polygonZ
@@ -32,28 +32,6 @@ module Picture
     , rotate
     , scale
     , color
-    , withAlpha
-    , greyN
-    , red       
-    , green     
-    , blue      
-    , yellow    
-    , cyan      
-    , magenta   
-    , rose      
-    , violet    
-    , azure     
-    , aquamarine
-    , chartreuse
-    , orange    
-    , white     
-    , black
-    , dim
-    , light
-    , dark
-    , bright
-    , brightX
-    , mixColors
     , zeroZ
     , setDepth
     , addDepth
@@ -64,6 +42,7 @@ import Geometry
 import Geometry.Vector3D
 --import Geometry.Data
 import Picture.Data
+import Color
 
 --import Data.List
 --import Data.Bifunctor
@@ -337,73 +316,6 @@ thickArcHelp startA endA rad wdth = map f
     (V2 xc yc) = rotateV endA (V2 rad 0)
     f (pos,col,V3 a b c) = Verx pos col [a,b,c] 0 arcNum
 
-withAlpha :: Float -> RGBA -> RGBA
-{-# INLINE withAlpha #-}
-withAlpha a (V4 x y z a') = V4 x y z (a*a')
-
-red,green,blue,yellow,cyan,magenta,rose
-    ,violet,azure,aquamarine,chartreuse,orange,white,black::Color
-red       = V4   1   0   0 1 
-green     = V4   0   1   0 1 
-blue      = V4   0   0   1 1 
-yellow    = V4   1   1   0 1  
-cyan      = V4   0   1   1 1 
-magenta   = V4   1   0   1 1  
-rose      = V4   1   0 0.5 1 
-violet    = V4 0.5   0   1 1  
-azure     = V4   0 0.5   1 1 
-aquamarine= V4   0   1 0.5 1 
-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
-        normratb = ratb / fullrat
-        f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
-    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
-
-brightX :: Float -> Float -> Color -> Color
-{-# INLINE brightX #-}
-brightX cm am (V4 r g b a) = V4 (r*cm) (g*cm) (b*cm) (a*am)
-
-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)
 
 -- Currently the lens version is much slower
 overPos :: (Point3 -> Point3) -> Verx -> Verx

src/Picture/Data.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Picture.Data
     where
@@ -27,8 +28,6 @@ textNum     = ShadNum 3
 arcNum      = ShadNum 4
 ellNum      = ShadNum 5
 type Picture = [Verx]
-type RGBA  = Point4
-type Color = Point4
 flat2 :: V2 a -> [a]
 flat2 (V2 x y) = [x,y]
 flat3 :: V3 a -> [a]

src/Polyhedra/Data.hs

@@ -14,7 +14,7 @@ newtype Polyhedra = Polyhedron
     { _pyFaces :: [[(Point3,Point4)]]
     }
 
--- | Describe a polygon as a map from vertex indices to a positiong and list of faces.
+-- | Describe a polygon as a map from vertex indices to a positioning and list of faces.
 -- The list of faces is assumed to be ordered in clockwise direction around the vertex.
 -- The vertices of the faces are assumed to start with a point adjacent to the
 -- key vertex and to be listed anticlockwise around the center of the face.

src/Preload/Render.hs

@@ -77,6 +77,7 @@ preloadRender = do
                 >>= addUniforms ["lightPos"]
 -- 2D draw shaders
     bslist <- makeShader "dualTwoD/basic"   [vert,frag] [3,4]   ETriangles 
+    bslista <- makeShader "dualTwoD/basic"   [vert,frag] [3,4]   ETriangles 
     aslist <- makeShader "dualTwoD/arc"     [vert,frag] [3,4,3] ETriangles 
     eslist <- makeShader "dualTwoD/ellipse" [vert,geom,frag] [3,4]   ETriangles 
     bezierQuadShader <- makeShader "dualTwoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip
@@ -151,6 +152,7 @@ preloadRender = do
 
     return $ RenderData
         { _pictureShaders = shadV
+        , _shapeShader = bslista
         , _lightingCapShader        = lightingCapShad
         , _lightingLineShadowShader = lightingLineShadowShad
         , _lightingOccludeShader    = wsShad    {_shadVAO = wpVAO}
@@ -171,7 +173,6 @@ preloadRender = do
         , _fboHalf3 = fboHalf3Name
         , _fboLighting = fboLightingName
         , _fboLightingHigh = fboLightingHighName
-        --, _rboLighting = rboLightingName
         , _fboBase  = fboBaseName
         , _fboCloud = fboCloudName
         , _fboBloom = fboBloomName

src/Shader/Bind.hs

@@ -16,6 +16,7 @@ import Control.Monad.Primitive
 import Control.Monad
 
 bindArrayBuffers :: Int -> VBO -> IO ()
+{-# INLINABLE bindArrayBuffers #-}
 bindArrayBuffers numVs theVBO = do
     bindBuffer ArrayBuffer $= Just (_vbo theVBO)
     bufferSubData 

src/Shader/Poke.hs

@@ -7,10 +7,13 @@ module Shader.Poke
     , pokePoint3s
     , pokePoint33s
     , poke224s
+    , pokeShape
+    , pokeShapeVs
     ) where
 import Shader.Data
 import Shader.Parameters
 import Picture.Data
+import Shape.Data
 import Geometry.Data
 
 import Foreign
@@ -37,6 +40,40 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
   where
     sn = _unShadNum theShadNum
 
+pokeShape :: Ptr Float -> Ptr Float -> Shape -> IO (Int,Int)
+pokeShape vptr eptr sh = do
+    nVs <- pokeShapeVs vptr (_shVertices sh)
+    nEs <- pokeShapeEs eptr (_shEdges sh)
+    return (nVs,nEs)
+
+pokeShapeVs :: Ptr Float -> [ShapeV] -> IO Int
+pokeShapeVs ptr vals0 = go vals0 0
+  where
+    go [] n = return n
+    go ( sh: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
+        go vals (n+1)
+      where
+        off i = n*7 + i
+        V3 a b c    = _svPos sh
+        V4 d e f g  = _svCol sh
+
+pokeShapeEs :: Ptr Float -> [Point3] -> IO Int
+pokeShapeEs ptr vals0 = go vals0 0
+  where
+    go [] n = return n
+    go ((V3 a b c) :vals) !n = do
+        pokeElemOff ptr (n * 3) a
+        pokeElemOff ptr (n * 3 + 1) b
+        pokeElemOff ptr (n * 3 + 2) c
+        go vals (n+1)
+
 pokeLayVerxs 
     :: MV.MVector (PrimState IO) FullShader 
     -> UMV.MVector (PrimState IO) Int

src/Shape.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE BangPatterns  #-}
+module Shape
+    ( module Shape.Data
+    , module Shape
+    )
+  where
+import Geometry
+--import Geometry.Vector3D
+import Shape.Data
+import Color
+
+empty :: Shape
+{-# INLINE empty #-}
+empty = Shape [] []
+
+flatPoly :: [Point2] -> Shape
+flatPoly ps = Shape
+    { _shVertices = polyToTris $ map f ps
+    , _shEdges = concat $ zipWith g ps (tail ps ++ [head ps])
+    }
+  where
+    f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
+    g (V2 x y) (V2 a b) =
+        [ V3 x y   0
+        , V3 a b   0
+        , V3 x y (-1)
+        , V3 a b   1
+        ]
+
+colorSh :: Color -> Shape -> Shape
+colorSh col = overCol $ const col
+
+overCol :: (Point4 -> Point4) -> Shape -> Shape
+overCol f Shape{_shVertices=vs,_shEdges=es} = Shape 
+    {_shVertices = map (overColVertex f) vs
+    ,_shEdges    = es
+    }
+
+overPos :: (Point3 -> Point3) -> Shape -> Shape
+overPos f Shape{_shVertices=vs,_shEdges=es} = Shape 
+    {_shVertices = map (overPosVertex f) vs
+    ,_shEdges    = map f es
+    }
+
+translateSh :: Point3 -> Shape -> Shape
+translateSh !p = overPos (+p)
+
+scale :: Point3 -> Shape -> Shape
+scale !p = overPos (*p)
+
+overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
+overColVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
+    {_svPos = pos
+    ,_svCol = f col
+    }
+
+overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
+overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
+    {_svPos = f pos
+    ,_svCol = col
+    }
+

src/Shape/Data.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Shape.Data
+    where
+import Geometry.Data
+import Control.Lens
+data Shape = Shape
+    { _shVertices :: [ShapeV]
+    , _shEdges    :: [Point3]
+    }
+-- edges are given by four consecutive points
+data ShapeV = ShapeV
+    { _svPos :: Point3
+    , _svCol :: Point4
+    }
+makeLenses ''ShapeV
+makeLenses ''Shape