Commit before attempting to change cloud shading

src/Data/Preload/Render.hs

@@ -62,6 +62,9 @@ data RenderData = RenderData
     , _toDiffuse :: TO
     , _wallVBO :: VBO
     , _wallShader :: FullShader
+    , _cloudVBO :: VBO
+    , _cloudShader :: Shader
+    , _cloudEBO :: EBO
     }
 
 makeLenses ''RenderData

src/Dodge/Item/Draw/SPic.hs

@@ -241,7 +241,10 @@ baseCaneShape :: Shape
 baseCaneShape = colorSH red $ upperPrismPoly 3 $ rectXH 15 1.5
 
 baseRifleShape :: Shape
-baseRifleShape = colorSH red $ upperPrismPoly 3 $ rectXH 25 2
+--baseRifleShape = colorSH red $ upperPrismPoly 3 $ rectXH 25 2
+--baseRifleShape = colorSH red . rotateSHq (V3 0 1 0) (pi/2) . upperCylinder 25 $ polyCirc 3 2
+--baseRifleShape = colorSH red $ xCylinder 4 2 25
+baseRifleShape = colorSH red $ xCylinder' 3 25
 
 addBullets :: Item -> Shape
 addBullets itm = fromMaybe mempty $ do
@@ -409,13 +412,14 @@ flamerPic it =
     am = fractionLoadedAmmo2 it
 
 launcherPic :: Item -> SPic
-launcherPic _ =
+launcherPic _ = noPic . colorSH cyan $ xCylinder' 5 20
-    ( colorSH cyan $
+--launcherPic _ = noPic . colorSH cyan $ xCylinder 4 5 20
-        prismPoly
+--    ( colorSH cyan $
-            (map (+.+.+ V3 20 0 5) $ polyCircx 4 5)
+--        prismPoly
-            (map (+.+.+ V3 0 0 5) $ polyCircx 4 5)
+--            (map (+.+.+ V3 20 0 5) $ polyCircx 4 5)
-    , mempty
+--            (map (+.+.+ V3 0 0 5) $ polyCircx 4 5)
-    )
+--    , mempty
+--    )
 
 baseRodShape :: Shape
 baseRodShape = colorSH orange $ upperPrismPoly 3 $ rectXH 20 2

src/Dodge/Render.hs

@@ -5,6 +5,7 @@ module Dodge.Render (
 
 --import qualified Data.Vector as V
 
+import Shader.Poke.Cloud
 import GLHelp
 import Control.Lens
 import Control.Monad
@@ -95,6 +96,14 @@ doDrawing' win pdata u = do
             , (pdata ^. wallVBO, trueNWalls)
             ]
     bufferPokedVBO (_vboShapes pdata) nShapeVs
+    (nCloudVs,nCloudIs) <- foldM (pokeCloud (pdata ^. cloudVBO . vboPtr) (pdata ^. cloudEBO . eboPtr))
+        (0,0) (w ^. cWorld . lWorld . clouds)
+    bufferPokedVBO (pdata ^. cloudVBO) nCloudVs
+    glNamedBufferSubData
+        (_eboName $ _cloudEBO pdata)
+        0
+        (fromIntegral $ glushortSize * nCloudIs)
+        (_eboPtr $ _cloudEBO pdata)
     glNamedBufferSubData
         (_eboName $ _shapeEBO pdata)
         0
@@ -242,6 +251,13 @@ doDrawing' win pdata u = do
         0
         ptr
     renderLayer MidLayer shadV layerCounts
+--    glUseProgram (pdata ^. cloudShader . shaderUINT)
+--    glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName
+--    glDrawElements
+--        (pdata ^. cloudShader . shaderPrimitive)
+--        (fromIntegral nCloudIs)
+--        GL_UNSIGNED_SHORT
+--        nullPtr
     drawShader (_windowShader pdata) nWins
 --    when (_graphics_cloud_shadows cfig) $ do
 --        ----render transparency depths

src/Preload/Render.hs

@@ -162,17 +162,19 @@ preloadRender = do
     wallTextureShad <-
         makeShaderUsingVAO "wall/texture" [vert, geom, frag] EPoints wpColVAO
     let wallverxstrd = 8
-    wallvbo <- setupVBO' wallverxstrd
+    wallvbo <- setupVBO wallverxstrd
     wallshader <- makeShader4 "wall/basic" [vert,geom,frag] [4,4] wallverxstrd EPoints wallvbo
     let floorverxstrd = 8
-    floorvbo <- setupVBO' floorverxstrd
+    floorvbo <- setupVBOStatic floorverxstrd
     floorshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4] floorverxstrd ETriangles floorvbo
     tonormalmap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png"
     todiffusemap <- initTexture2DArray 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png"
 
---    let cloudverxstrd = 16
+    let cloudverxsizes = [4,4,4,4]
---    cloudvbo <- setupVBO' cloudverxstrd
+    cloudvbo <- setupVBO (sum cloudverxsizes)
---    cloudshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4,4,4] cloudverxstrd ETriangles floorvbo
+    (cloudshader, cloudebo) 
+        <- makeShaderEBO "floor/arrayPos" [vert, frag] cloudverxsizes (sum cloudverxsizes) 
+            GL_TRIANGLES floorvbo
     -- bind fixed vertex data
     bufferPokedVBO (snd fsShad) 4
     framebuf2 <- setupTextureFramebuffer 800 600
@@ -261,6 +263,9 @@ preloadRender = do
             , _toDiffuse = todiffusemap
             , _wallVBO = wallvbo
             , _wallShader = wallshader
+            , _cloudVBO = cloudvbo
+            , _cloudShader = cloudshader
+            , _cloudEBO = cloudebo
             }
 
 --------------------end preloadRender

src/Shader/Compile.hs

@@ -1,7 +1,7 @@
 module Shader.Compile (
     setupVBO,
-    setupVBO',
+    setupVBOStatic,
-    makeShaderVAOEBO,
+    makeShaderEBO,
     makeShader,
     makeShader4,
     makeByteStringShaderUsingVAO,
@@ -47,7 +47,7 @@ makeShader s shaderlist sizes pm = do
             }
             , vbo)
 
-makeShaderVAOEBO ::
+makeShaderEBO ::
     -- | First part of the name of the shader
     String ->
     -- | shader types
@@ -58,14 +58,13 @@ makeShaderVAOEBO ::
     Int ->
     GLenum ->
     VBO ->
-    IO (Shader, VAO, EBO)
+    IO (Shader, EBO)
-makeShaderVAOEBO s shaderlist sizes strd pm vbo = do
+makeShaderEBO s shaderlist sizes strd pm vbo = do
     prog <- makeSourcedShader s shaderlist
     vao <- setupVAOvbo sizes strd vbo
     ebo <- setupEBO vao
     return
-        ( Shader prog pm
+        ( Shader prog pm vao
-        , vao
         , ebo
         )
 
@@ -102,8 +101,8 @@ setupVBO vertexsize = do
         GL_STREAM_DRAW
     return VBO {_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
 
-setupVBO' :: Int -> IO VBO
+setupVBOStatic :: Int -> IO VBO
-setupVBO' vertexsize = do
+setupVBOStatic vertexsize = do
     vboname <- mglCreate glCreateBuffers
     thePtr <- mallocArray (vertexsize * numDrawableElements)
     -- Allocate space

src/Shader/Data.hs

@@ -13,6 +13,7 @@ module Shader.Data
     , vaoName
     , shaderUINT
     , shaderPrimitive
+    , shaderVAO
 
     , textureObject
 
@@ -45,6 +46,7 @@ data FullShader = FullShader
 data Shader = Shader
     { _shaderUINT :: GLuint -- should be shaderID
     , _shaderPrimitive :: GLenum
+    , _shaderVAO :: VAO
     }
 {- | Vertex array object: contains the reference to the object,
 and its buffer targets.  -}

src/Shader/Poke/Cloud.hs

@@ -0,0 +1,33 @@
+module Shader.Poke.Cloud (
+    pokeCloud,
+) where
+
+import qualified Data.Vector.Unboxed as UV
+import Dodge.Data.Cloud
+import Foreign
+import Geometry
+import Graphics.GL.Core45
+
+pokeCloud :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Cloud -> IO (Int, Int)
+pokeCloud vptr iptr (nv,ni) cl = do
+    UV.imapM_ (pokeCloudVerx vptr cl nv) $ UV.fromList [(1, 1), (1, -1), (-1, -1), (-1, 1)]
+    UV.imapM_ (pokeCloudIndex iptr nv ni) $ UV.fromList [0, 1, 2, 2, 1, 3]
+    return (nv + 4, ni + 6)
+
+pokeCloudVerx :: Ptr Float -> Cloud -> Int -> Int -> (Float, Float) -> IO ()
+pokeCloudVerx ptr cl nv i (dx, dy) =
+    UV.imapM_ (pokeCloudFloat ptr (nv + i)) $ UV.fromList 
+        [x, y, cz, 1, r, g, b, a, cx, cy, cz, rad, dx, dy, 0, 0]
+  where
+    V3 cx cy cz = _clPos cl
+    V2 x y = V2 cx cy - rad *.* V2 dx dy
+    rad = _clRad cl
+    V4 r g b a = case _clPict cl of
+        CloudColor _ _ col -> col
+        DrawGasCloud col -> col
+
+pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
+pokeCloudFloat ptr nv i = pokeElemOff ptr (nv * 16 + i)
+
+pokeCloudIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO ()
+pokeCloudIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)

src/Shape.hs

@@ -11,6 +11,7 @@ module Shape
     , translateSHxy
     , rotateSH
     , rotateSHx
+    , rotateSHq
     , polyCircx
     , scaleSH
     , colorSH
@@ -18,10 +19,13 @@ module Shape
     , overPosSH
     , upperCylinder
     , upperRounded
+    , xCylinder
+    , xCylinder'
     ) where
 import Geometry
 import Shape.Data
 import Color
+import qualified Quaternion as Q
 
 -- - approximate a circle by a polygon with n*2 points of radius x
 polyCirc :: Int -> Float -> [Point2]
@@ -41,7 +45,6 @@ prismPoly
     -> [Point3] 
     -> Shape
 {-# INLINE prismPoly #-}
---prismPoly upps downps = [Surface (TopPrism n) (f upps downps) white FullShadowFidelity]
 prismPoly upps downps = [Surface (RoundedFaces n) (cp:cp:f upps downps) white FullShadowFidelity]
   where
     cp = centroidNum $ upps ++ downps
@@ -56,6 +59,17 @@ upperPrismPoly
 {-# INLINE upperPrismPoly #-}
 upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps)
 
+xCylinder :: Int -> Float -> Float -> Shape
+xCylinder n r x = rotateSHq (V3 0 1 0) (pi/2) . translateSHxy (-r) 0 . upperCylinder x $ polyCirc n r
+
+xCylinder' :: Float -> Float -> Shape
+xCylinder' r x = translateSHz r . rotateSHq (V3 0 1 0) (pi/2) . upperCylinder x $ 
+    [V2 r    (r)
+    ,V2 (-r/2) (r/2)
+    ,V2 (-r/2) (negate $ r/2)
+    ,V2 r    (-r)
+    ]
+
 upperBox 
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 
@@ -68,6 +82,9 @@ upperBox h ps = [Surface (FlatFaces n) (f ps) white FullShadowFidelity]
     f (x:xs) = g h x : g 0 x : f xs
     f _ = []
 
+rotateSHq :: Point3 -> Float -> Shape -> Shape
+rotateSHq p = overPosSH . Q.rotate . Q.axisAngle p
+
 upperCylinder 
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 
@@ -75,7 +92,7 @@ upperCylinder
 {-# INLINE upperCylinder #-}
 upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white FullShadowFidelity]
   where
-    cc = centroid ps
+    cc = V2 0 0
     n = length ps
     g h' (V2 x y) = V3 x y h'
     f (x:xs) = g h x : g 0 x : f xs