Add file, move buffer swapping into doDrawing

src/Dodge/Render/Shadow.hs

@@ -0,0 +1,96 @@
+module Dodge.Render.Shadow where
+
+import Shader.Parameters
+import Shader.ExtraPrimitive
+import Graphics.Rendering.OpenGL (currentProgram, ($=), bindVertexArrayObject, bindBuffer
+    , BufferTarget (..), bufferSubData, TransferDirection (..)
+    )
+import Graphics.GL.Core43
+import Geometry
+import Linear.V3 (cross)
+--import Data.Vector.Unboxed as UV
+import qualified Data.Vector as V
+import Shader.Data
+import Foreign
+import Shape.Data
+import Data.Preload.Render
+--import Dodge.Data.Universe
+import Control.Lens
+import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
+
+drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO ()
+drawCPUShadows pdata s pos rad = do
+    let theshad = pdata ^. positionalBlankShader  
+        theptr = _vboPtr $ _vaoVBO $ _shadVAO theshad
+    i <- VFSM.foldlM' (pokeShapeShad pos rad theptr) 0 $ VFSM.fromList s
+    bindBuffer ArrayBuffer $= (theshad ^? shadVAO . vaoVBO . vbo)
+    bufferSubData
+        ArrayBuffer
+        WriteToBuffer
+        0
+        (fromIntegral $ floatSize * i)
+        (theshad ^. shadVAO . vaoVBO . vboPtr)
+    currentProgram $= theshad ^? shadProg
+    bindVertexArrayObject $= Just (_vao $ _shadVAO theshad)
+    glDrawArrays
+        (marshalEPrimitiveMode $ _shadPrim theshad) 
+        0
+        (fromIntegral i)
+    return ()
+
+pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int
+pokeShapeShad pos r theptr i so = do
+    let vs = V.fromList $ map _svPos (_shVs so)
+        is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2)
+    V.foldM' (pokeShadEdge pos r theptr vs) i is
+
+pokeShadEdge :: Point3 -> Float -> Ptr Float -> V.Vector Point3 
+    -> Int -> (Int,Int,Int,Int) -> IO Int
+pokeShadEdge pos _ ptr vxs i (a,b,x,y) = do
+    let p0 = vxs V.! a
+        p1 = vxs V.! b
+        --mid = 0.5 * (p0 + p1)
+        n0a = vxs V.! x
+        n1a = vxs V.! y             -- this should almost certainly be done with backpermute
+        n0 = cross (p1 - p0) (n0a - p0)
+        n1 = cross (p0 - p1) (n1a - p1)
+        lightdir = p0 - pos
+        shift' p = p + (10000 *.*.* (p - pos))
+--        projNear p = 
+--        shiftNear p = 
+    if dotV3 n0 lightdir * dotV3 n1 lightdir <=0 
+    then do
+        let p2 = shift' p0
+            p3 = shift' p1
+        if dotV3 n0 lightdir > 0
+            then
+                pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2
+                    >>= pokeV3 ptr p0 >>= pokeV3 ptr p2 >>= pokeV3 ptr p3
+            else
+                pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3 
+                    >>= pokeV3 ptr p1 >>= pokeV3 ptr p3 >>= pokeV3 ptr p2
+    else
+        return i
+
+pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int
+pokeV3 ptr (V3 x y z) i = do
+    pokeElemOff ptr (3 * i) x
+    pokeElemOff ptr (3 * i + 1) y
+    pokeElemOff ptr (3 * i + 2) z
+    return (i + 1)
+
+memoTopPrismEdges :: V.Vector (V.Vector (Int,Int,Int,Int))
+memoTopPrismEdges = V.generate 10 
+    $ V.fromList . topPrismEdges . (+ 2)
+
+topPrismEdges :: Int -> [(Int,Int,Int,Int)]
+topPrismEdges n = concatMap f [0..n-1]
+  where
+    f i = map h
+        [ (0 , 2 , 1 , 4)
+        , (0 , 1 ,-2 , 3)
+        , (1 , 3 ,-1 , 2)
+        ]
+      where
+        h (a,b,c,d) = (g a,g b,g c, g d)
+        g j = (2 * i + j) `mod` (2*n)