Working dynamic shadows using shape vertices buffer

src/Dodge/Creature/Picture.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 {- |
 Drawing of creatures. 
 Takes into account damage etc. -}
@@ -55,6 +55,7 @@ basicCrShape col cr = tr $ mconcat
     , translateSHz 25 . dm . rotdir $ scalp cr
     , dm . rotmdir $ feet cr
     , dm . rotdir $ upperBody col cr
+    , rotdir $ _spShape $ drawEquipment cr
     ]
   where 
     dm = damageModSH cr

src/Dodge/Data.hs

@@ -75,9 +75,6 @@ data World = World
     , _playingSounds        :: M.Map SoundOrigin Sound
     , _decorations          :: IM.IntMap Picture
     , _foregroundShape      :: Shape
-    --, _foregroundDecorations :: [Polyhedra]
-    , _foregroundDecorations :: Shape
-    , _foregroundEdgeVerx   :: [Point3]
     , _corpses              :: Zone [Corpse]
     , _clickMousePos        :: !Point2
     , _pathGraph            :: ~(Gr Point2 Float)

src/Dodge/Default.hs

@@ -36,7 +36,7 @@ defaultCreature = Creature
     , _crOldDir = 0
     , _crMvDir  = 0
     , _crID     = 1
-    , _crPict   = \_ _ -> (,) (mempty) blank
+    , _crPict   = \_ _ -> (,) mempty blank
     , _crUpdate = \cr _ -> (Endo id , Just cr)
     , _crRad    = 10
     , _crMass   = 10
@@ -200,7 +200,7 @@ defaultIt = Consumable
     , _itAmount = 2
     , _cnEffect = const return
     , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> (,) emptySH $ blank
+    , _itEquipPict = \_ _ -> (,) emptySH blank
     , _itID = Nothing
     , _itInvDisplay = _itName
     , _itInvColor = blue

src/Dodge/Default/World.hs

@@ -80,8 +80,6 @@ defaultWorld = World
     , _inventoryMode = TopInventory
     , _lClickHammer = HammerUp
     , _foregroundShape = mempty
-    , _foregroundDecorations = mempty
-    , _foregroundEdgeVerx = []
     , _radDistortion = []
     , _gameRooms = []
     , _preloadData = DummyPdata -- hack TODO remove this

src/Dodge/Item/Equipment.hs

@@ -16,7 +16,7 @@ magShield = defaultEquipment
     , _itMaxStack = 1
     , _itAmount = 1
     , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> (,) emptySH $ blank
+    , _itEquipPict = \_ _ -> (,) emptySH blank
     , _itID = Nothing
     }
 flameShield :: Item 

src/Dodge/Item/Weapon.hs

@@ -440,15 +440,18 @@ spreadGun = defaultGun
         ]
     , _wpSpread = spreadGunSpread
     , _wpRange = 20
-    , _itFloorPict = (,) emptySH $ onLayer FlItLayer spreadGunPic
+    , _itFloorPict = spreadGunPic
     , _itAimingSpeed = 1
     , _itAimingRange = 0
-    , _itEquipPict = pictureWeaponOnAim $ (,) emptySH spreadGunPic
+    , _itEquipPict = pictureWeaponOnAim $ spreadGunPic
     , _wpAmmo = basicBullet
     , _wpNumBarrels = 50
     }
-spreadGunPic :: Picture
+spreadGunPic :: SPic
-spreadGunPic = color green $ pictures [ polygon $ map toV2[(-3,0),(3,6),(3,-6)] ]
+spreadGunPic = 
+    ( colorSH green $ upperPrismPoly 5 $ map toV2[(-3,0),(3,6),(3,-6)]
+    , mempty
+    )
 multGun :: Item
 multGun = defaultGun 
     { _itName = "MULTGUN"
@@ -1111,7 +1114,7 @@ autoSonar = defaultEquipment
     , _itMaxStack = 1
     , _itAmount = 1
     , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> (,) emptySH $ blank
+    , _itEquipPict = \_ _ -> (,) emptySH blank
     , _itEffect = autoSonarEffect
     , _itID = Nothing
     , _itAimingSpeed = 1
@@ -1128,7 +1131,7 @@ autoRadar = defaultEquipment
     , _itMaxStack = 1
     , _itAmount = 1
     , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> (,) emptySH $ blank
+    , _itEquipPict = \_ _ -> (,) emptySH blank
     , _itEffect = autoRadarEffect
     , _itID = Nothing
     , _itAimingSpeed = 1

src/Dodge/Item/Weapon/AutoGun.hs

@@ -9,14 +9,13 @@ import Dodge.Item.Weapon.ExtraEffect
 import Dodge.Item.Weapon.InventoryDisplay
 import Dodge.Item.Weapon.AmmoParams
 import Dodge.Item.Data
-import Dodge.Picture.Layer
 import Dodge.Item.Draw
 import Dodge.Item.Weapon.Bullet
 import Dodge.Item.Weapon.TriggerType
 import Dodge.SoundLogic.LoadSound
 import Picture
 import Geometry
---import ShapePicture
+import ShapePicture
 import Shape
 
 import qualified Data.Sequence as Seq
@@ -51,20 +50,23 @@ autoGun = defaultAutoGun
     , _wpSpread = autogunSpread
     , _wpRange = 20
     , _itHammer = HammerUp
-    , _itFloorPict = (,) emptySH $ onLayer FlItLayer autoGunPic
+    , _itFloorPict = autoGunPic
     , _itAimingSpeed = 0.4
     , _itAimingRange = 1
     , _itZoom = defaultItZoom 
     , _itAimZoom = defaultItZoom {_itZoomFac = 1.5}
-    , _itEquipPict = pictureWeaponOnAim $ (,) emptySH autoGunPic
+    , _itEquipPict = pictureWeaponOnAim autoGunPic
     , _itEffect = wpRecock
     , _itAttachment = ItCharMode $ Seq.fromList "MS"
     , _itScroll   = scrollCharMode
     , _itInvDisplay = basicWeaponDisplay
     , _wpAmmo = basicBullet    
     }
-autoGunPic :: Picture
+autoGunPic :: SPic
-autoGunPic = color red $ polygon $ rectNESW 4 12 (-4) (-12)
+autoGunPic =
+    ( colorSH red $ upperPrismPoly 5 $ rectNESW 4 12 (-4) (-12)
+    , mempty
+    )
 
 autogunSpread :: Float
 autogunSpread = 0.07

src/Dodge/Item/Weapon/TriggerType.hs

@@ -308,7 +308,7 @@ withTempLight time rad col eff item cr = eff item cr
 
 modClock :: Int -> ChainEffect -> ChainEffect
 modClock n chainEff eff it cr w
-    | _frameClock w `mod` n == 0 = (chainEff eff) it cr w
+    | _frameClock w `mod` n == 0 = chainEff eff it cr w
     | otherwise = eff it cr w
 
 withMuzFlareI :: ChainEffect

src/Dodge/Layout.hs

@@ -42,7 +42,7 @@ generateLevelFromRoomList gr w
     = updateWallZoning 
     . setupWorldBounds
 --    . initializeStaticWalls
-    . setupForegroundEdgeVerxs
+--    . setupForegroundEdgeVerxs
     . placeSpots plmnts
 --    . addRoomPolyDecorations rs
 --    . addRoomLinkDecorations rs
@@ -76,9 +76,6 @@ setupWorldBounds w = w
         <*> L.premap sndV2 L.maximum
         ) ps
 
-setupForegroundEdgeVerxs :: World -> World
-setupForegroundEdgeVerxs w = w & foregroundShape .~ (_foregroundDecorations w)
-
 polyhedrasToEdges :: [Polyhedra] -> [Point3]
 polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
 

src/Dodge/LevelGen.hs

@@ -99,7 +99,7 @@ placeSpot ps w = case _psType ps of
       where 
         (q:qs) = map (shiftPointBy (p,rot)) ps'
         rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
-    PutForeground sh -> w & foregroundDecorations %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)
+    PutForeground sh -> w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)
     PutNothing -> w
     PutID _ -> w
     --_   -> w

src/Dodge/Render.hs

@@ -106,7 +106,7 @@ doDrawing pdata w = do
     glDrawElements
         (marshalEPrimitiveMode $ _shadPrim fs) 
         (fromIntegral nIndices)
-        (GL_UNSIGNED_SHORT)
+        GL_UNSIGNED_SHORT
         nullPtr
 
     --draw floor onto base buffer

src/Dodge/Room/Foreground.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Foreground
     where
 import Dodge.Picture

src/Render.hs

@@ -77,7 +77,7 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
         glDrawElements
             (marshalEPrimitiveMode $ _shadPrim llss) 
             (fromIntegral nSils)
-            (GL_UNSIGNED_SHORT)
+            GL_UNSIGNED_SHORT
             nullPtr
         cullFace $= Just Back
 
@@ -91,7 +91,7 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
         glDrawElements
             (marshalEPrimitiveMode $ _shadPrim fs) 
             (fromIntegral nCaps)
-            (GL_UNSIGNED_SHORT)
+            GL_UNSIGNED_SHORT
             nullPtr
         --drawShader (_lightingCapShader pdata) nCaps
         --draw lightmap itself

src/Shader/Poke.hs

@@ -48,7 +48,7 @@ pokeShape
     -> Ptr GLushort -- ^ edge indices pointer
     -> Shape 
     -> IO (Int,Int,Int)
-pokeShape vptr iptr ieptr = pokeShapeObjs vptr iptr ieptr (0,0,0) . fst
+pokeShape vptr iptr ieptr = pokeShapeObjs vptr iptr ieptr (0,0,0)
 
 pokeShapeObjs 
     :: Ptr Float 
@@ -96,7 +96,7 @@ topPrismEdgeIndices n = concatMap f [0..n-1]
         , 1 , 3 ,-1 , 2
         ]
       where
-        g j = (2 * i + j) `mod` n
+        g j = (2 * i + j) `mod` (2*n)
 
 topPrismIndices :: Int -> [Int]
 topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face

src/Shape.hs

@@ -14,29 +14,23 @@ module Shape
   where
 import Geometry
 import Geometry.Vector3D
-import Geometry.ConvexPoly
 import Shape.Data
 import Color
 
-import Data.Bifunctor
-
 emptySH :: Shape
 {-# INLINE emptySH #-}
 emptySH = mempty
 
 polyCirc :: Int -> Float -> [Point2]
 {-# INLINE polyCirc #-}
-polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/(fromIntegral n)..]
+polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/fromIntegral n..]
 
 upperPrismPoly 
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPoly #-}
-upperPrismPoly h ps =
+upperPrismPoly h ps = [ShapeObj (TopPrism n) (f upps downps)]
-    ( [ShapeObj (TopPrism n) (f upps downps)]
-    , topEdges <> bottomEdges <> sideEdges
-    )
   where
     n = length ps
     upps = map f' ps
@@ -46,13 +40,6 @@ upperPrismPoly h ps =
     f _ [] = []
     f' (V2 x y) = pairToSV (V3 x y h, black)
     f'' (V2 x y) = pairToSV (V3 x y 0, black)
-    topEdges = shEfromList $ concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
-    makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h]
-    V2 xcen ycen = centroid ps
-    bottomEdges = shEfromList $ concat $ zipWith makeBottomEdge ps (tail ps ++ [head ps])
-    makeBottomEdge (V2 x' y') (V2 x y) = [V3 x y 0,V3 x' y' 0,V3 x y h,V3 xcen ycen 0]
-    sideEdges = shEfromList $ concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
-    makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h]
 
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
@@ -60,11 +47,11 @@ colorSH col = overCol $ const col
 
 overCol :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overCol #-}
-overCol f = first (fmap $ overColObj f)
+overCol f = fmap $ overColObj f
 
 overPos :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPos #-}
-overPos f = bimap (fmap $ overPosObj f) (fmap f)
+overPos f = fmap $ overPosObj f
 
 translateSH :: Point3 -> Shape -> Shape
 {-# INLINE translateSH #-}
@@ -84,7 +71,7 @@ rotateSH a = overPos (rotate3 a)
 
 scaleSH :: Point3 -> Shape -> Shape
 {-# INLINE scaleSH #-}
-scaleSH !(V3 a b c) = overPos (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
+scaleSH (V3 a b c) = overPos (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
 
 overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj
 {-# INLINE overColObj #-}

src/Shape/Data.hs

@@ -6,25 +6,20 @@
 module Shape.Data
     where
 import Geometry.Data
+
+import Control.Lens
 --import qualified Data.DList as DL
 
-type Shape = ([ShapeObj], [Point3])
+type Shape = [ShapeObj]
 
 _shVertices :: Shape -> [ShapeV]
 {-# INLINE _shVertices #-}
-_shVertices = concatMap _shVs . fst
+_shVertices = concatMap _shVs
-_shEdges :: Shape -> [Point3]
-{-# INLINE _shEdges #-}
-_shEdges = snd
 
 shVList :: Shape -> [ShapeV]
 {-# INLINE shVList #-}
 shVList = _shVertices
 --shVList = DL.toList . _shVertices
-shEList :: Shape -> [Point3]
-{-# INLINE shEList #-}
-shEList = _shEdges
---shEList = DL.toList . _shEdges
 
 {-# INLINE shVfromList #-}
 shVfromList = id
@@ -38,9 +33,7 @@ data ShapeObj = ShapeObj
     , _shVs :: [ShapeV]
     }
 
-data ShapeType
+newtype ShapeType = TopPrism Int
-    = TopPrism Int
---    | ListV
 
 -- edges are given by four consecutive points
 data ShapeV = ShapeV
@@ -51,7 +44,4 @@ pairToSV :: (Point3,Point4) -> ShapeV
 {-# INLINE pairToSV #-}
 pairToSV = uncurry ShapeV
 
---_svPos :: ShapeV -> Point3
+makeLenses ''ShapeV
---_svPos = fst
---_svCol :: ShapeV -> Point4
---_svCol = snd