Add trajectory to grenades, various refactoring

src/Data/Preload/Render.hs

@@ -12,9 +12,7 @@ import qualified Data.Vector.Mutable as MV
 import Control.Monad.Primitive
 
 data RenderData = RenderData
-    { _lightingOccludeShader    :: FullShader
+    { _lightingWallShadShader    :: FullShader
-    --, _lightingWallShader       :: FullShader
-    --, _lightingSurfaceShader    :: FullShader
     , _lightingLineShadowShader :: FullShader
     , _lightingCapShader        :: FullShader
     , _wallBlankShader          :: FullShader

src/Dodge/Base.hs

@@ -151,7 +151,7 @@ adjustIMZone f x y n = IM.adjust f' x
     f'' = IM.adjust f n
 {- | Finds unused projectile key. -}
 newProjectileKey :: World -> Int
-newProjectileKey = IM.newKey . _projectiles
+newProjectileKey = IM.newKey . _props
 {- | Finds unused creature key. -}
 newCrKey :: World -> Int
 newCrKey = IM.newKey .  _creatures
@@ -256,8 +256,8 @@ collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Lef
 
 -- | Looks for first collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
-collideCircWalls'' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collideCircWalls'' p1 p2 rad ws 
+collideCircWalls p1 p2 rad ws 
     = safeMinimumOn (dist p1 . fst) 
     $ IM.mapMaybe 
         (( \(x:y:_) -> fmap 

src/Dodge/Creature.hs

@@ -162,6 +162,7 @@ startInventory :: IM.IntMap Item
 startInventory = IM.fromList (zip [0..20] 
     (
     [spreadGun
+    ,longGun
     ,autoGun
     ,ltAutoGun
     ,hvAutoGun

src/Dodge/Creature/Picture.hs

@@ -53,7 +53,7 @@ basicCrShape
     -> Shape
 basicCrShape col cr = tr $ mconcat
     [ rotdir . _spShape $ drawEquipment cr
-    , rotdir . dm . translateSHz 25 $ scalp cr
+    , rotdir . dm . translateSHz 20 $ scalp cr
     , rotdir . dm $ upperBody col cr
     , dm . rotmdir $ feet cr
     ]
@@ -164,7 +164,7 @@ arms cr
         _ -> emptySH 
   where
     aHand :: Shape
-    aHand = translateSHz (-4) . upperPrismPoly 4 $ polyCirc 3 4
+    aHand = translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
     crad = _crRad cr
     off = 8
     sLen = _strideLength $ _crStance cr
@@ -177,7 +177,7 @@ scalp cr
     | oneH   cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
     | otherwise = translateSHf (0.25 * crad) 0 fhead
   where
-    fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
+    fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 . polyCirc 4 $ crad * 0.5
     crad = _crRad cr
 
 oneH :: Creature -> Bool
@@ -212,7 +212,7 @@ torso cr
 
 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}
-baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 1
+baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10 $ polyCirc 3 1
 
 upperBody :: Color -> Creature -> Shape
 {-# INLINE upperBody #-}

src/Dodge/Data.hs

@@ -56,7 +56,7 @@ data World = World
     , _itemPositions        :: IM.IntMap ItemPos
     , _clouds               :: [Cloud]
     , _cloudsZone           :: Zone [Cloud]
-    , _projectiles          :: IM.IntMap Projectile
+    , _props                :: IM.IntMap Prop
     , _particles            :: ![Particle]
     , _walls                :: !(IM.IntMap Wall)
     , _wallsZone            :: Zone (IM.IntMap Wall)
@@ -455,7 +455,7 @@ data Ammo
         { _amPayload :: Point2 -> World -> World
         , _amString :: String
         , _amPjParams :: [PjParam]
-        , _amPjDraw :: Projectile -> Picture
+        , _amPjDraw :: Prop -> SPic
         , _amParamSel :: Int
         }
     | BulletAmmo
@@ -466,19 +466,19 @@ data Ammo
         }
     | GenericAmmo
 data PjParam = PjParam
-    { _pjMoveParam :: Int -> Item -> Creature -> Projectile -> World -> World
+    { _pjMoveParam :: Int -> Item -> Creature -> Prop -> World -> World
     , _pjIntParam  :: Int
     , _pjMaxParam  :: Int
     , _pjDisplayParam :: Int -> String
     }
-data Projectile 
+data Prop 
     = Projectile    
         { _pjPos :: Point2
         , _pjStartPos :: Point2
         , _pjVel :: Point2
-        , _pjDraw :: Projectile -> Picture
+        , _prDraw :: Prop -> SPic
         , _pjID :: Int
-        , _pjUpdate :: Projectile -> World -> World
+        , _pjUpdate :: Prop -> World -> World
         }
     | Shell 
         { _pjPos :: Point2
@@ -487,16 +487,28 @@ data Projectile
         , _pjAcc :: Point2
         , _pjDir :: Float
         , _pjSpin :: Float
-        , _pjDraw :: Projectile -> Picture
+        , _prDraw :: Prop -> SPic
         , _pjID :: Int
-        , _pjUpdate :: Projectile -> World -> World
+        , _pjUpdate :: Prop -> World -> World
+        , _pjPayload :: Point2 -> World -> World
+        , _pjTimer :: Int
+        , _pjZ :: Float
+        }
+    | Bomb 
+        { _pjPos :: Point2
+        , _pjVel :: Point2
+        , _pjZ   :: Float
+        , _pjVelZ :: Float
+        , _prDraw :: Prop -> SPic
+        , _pjID :: Int
+        , _pjUpdate :: Prop -> World -> World
         , _pjPayload :: Point2 -> World -> World
         , _pjTimer :: Int
         }
     | LinearShockwave 
-        { _pjDraw :: Projectile -> Picture
+        { _prDraw :: Prop -> SPic
         , _pjID :: Int
-        , _pjUpdate :: Projectile -> World -> World
+        , _pjUpdate :: Prop -> World -> World
         , _pjPoints :: [(Point2,Point2)]
         , _pjTimer :: Int
         }
@@ -720,7 +732,7 @@ makeLenses ''ItZoom
 makeLenses ''FloorItem
 makeLenses ''Ammo
 makeLenses ''PjParam
-makeLenses ''Projectile
+makeLenses ''Prop
 makeLenses ''Particle
 makeLenses ''Wall
 makeLenses ''ForceField

src/Dodge/Debug.hs

@@ -14,45 +14,45 @@ import qualified Data.IntSet as IS
 import Control.Lens
 
 drawCircleAtFor :: Point2 -> Int -> World -> World
-drawCircleAtFor p t w = w & projectiles %~ 
+drawCircleAtFor p t w = w & props %~ 
     IM.insert k Projectile 
         { _pjPos = p
         , _pjStartPos = p
         , _pjVel = V2 0 0
-        , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
+        , _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
         , _pjID = k
         , _pjUpdate = \_ -> pjTimerF t k
         }
   where
-    k = IM.newKey $ _projectiles w
+    k = IM.newKey $ _props w
 drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
-drawCircleAtForCol p t col w = w & projectiles %~
+drawCircleAtForCol p t col w = w & props %~
     IM.insert k Projectile 
         { _pjPos = p
         , _pjStartPos = p
         , _pjVel = V2 0 0
-        , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20
+        , _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20
         , _pjID = k
         , _pjUpdate = \_ -> pjTimerF t k
         }
   where
-    k = IM.newKey $ _projectiles w
+    k = IM.newKey $ _props w
 drawLineForCol :: [Point2] -> Int -> Color -> World -> World
-drawLineForCol ps t col w = w & projectiles %~
+drawLineForCol ps t col w = w & props %~
     IM.insert k Projectile 
         { _pjPos = head ps
         , _pjStartPos = head ps
         , _pjVel = V2 0 0
-        , _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps
+        , _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ color col $ lineOfThickness 5 ps
         , _pjID = k
         , _pjUpdate = \_ -> pjTimerF t k
         }
   where
-    k = IM.newKey $ _projectiles w
+    k = IM.newKey $ _props w
 
 pjTimerF :: Int -> Int -> World -> World
-pjTimerF 0    i = projectiles %~ IM.delete i
+pjTimerF 0    i = props %~ IM.delete i
-pjTimerF time i = projectiles . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
+pjTimerF time i = props . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
 
 drawDDA :: IM.IntMap IS.IntSet -> Picture
 drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank

src/Dodge/Default.hs

@@ -221,12 +221,12 @@ defaultButton = Button
     , _btText = "Button"
     , _btState = BtOff
     }
-defaultPT :: Projectile
+defaultPT :: Prop
 defaultPT = Projectile
     { _pjPos = V2 0 0
     , _pjStartPos = V2 0 0
     , _pjVel = V2 0 0
-    , _pjDraw = const blank
+    , _prDraw = const mempty
     , _pjID = 0
     , _pjUpdate = const id
     }

src/Dodge/Default/Shell.hs

@@ -4,15 +4,16 @@ import Dodge.Data
 import Picture
 import Geometry.Data
 
-defaultShell :: Projectile
+defaultShell :: Prop
 defaultShell = Shell
     { _pjPos = V2 0 0
+    , _pjZ   = 20
     , _pjStartPos = V2 0 0
     , _pjVel = V2 0 0
     , _pjAcc = V2 0 0
     , _pjDir = 0
     , _pjSpin = 0
-    , _pjDraw = const blank
+    , _prDraw = const (mempty, blank)
     , _pjID = 0
     , _pjTimer = 0
     , _pjUpdate = const id

src/Dodge/Default/Weapon.hs

@@ -58,6 +58,6 @@ defaultShellAmmo = ShellAmmo
     { _amPayload = const id
     , _amString = "Shell"
     , _amPjParams = []
-    , _amPjDraw = const blank
+    , _amPjDraw = const mempty
     , _amParamSel = 0
     }

src/Dodge/Default/World.hs

@@ -33,7 +33,7 @@ defaultWorld = World
     , _clouds = []
     , _cloudsZone = Zone IM.empty
     , _itemPositions = IM.empty
-    , _projectiles = IM.empty
+    , _props = IM.empty
     , _particles = []
     , _walls = IM.empty
     , _wallsZone = Zone IM.empty

src/Dodge/Initialisation.hs

@@ -42,7 +42,7 @@ initialWorld = defaultWorld
     , _cameraRot = 0
     , _cameraZoom = 10
     , _creatures = IM.fromList [(0,startCr)]
-    , _projectiles = IM.empty
+    , _props = IM.empty
     , _walls = IM.empty
     , _forceFields = IM.empty
     , _floorItems = IM.empty

src/Dodge/Item/Weapon.hs

@@ -688,11 +688,11 @@ aTeslaArc cr w
     chooseColor 2 = blue
     chooseColor _ = cyan
 
-remoteShellPic' :: Projectile -> Picture
+remoteShellDraw :: Prop -> SPic
-remoteShellPic' pj
+remoteShellDraw pj
-    | t > 40 = onLayerL [levLayer CrLayer - 2] 
+    | t > 40 = (,) mempty $ onLayerL [levLayer CrLayer - 2] 
                         $ uncurryV translate pos $ rotate dir $ remoteShellPic t
-    | otherwise = uncurryV translate pos $ rotate dir $ remoteShellPic t
+    | otherwise = (,) mempty $ uncurryV translate pos $ rotate dir $ remoteShellPic t
   where
     t = _pjTimer pj
     pos = _pjPos pj
@@ -751,16 +751,16 @@ retireRemoteRocket :: Int -> Int -> Int -> World -> World
 retireRemoteRocket itid 0 pjid w = 
     set (pointToItem (_itemPositions w IM.! itid) . itAttachment . scopePos) (V2 0 0)
     $ set (pointToItem (_itemPositions w IM.! itid) . itUse) (const fireRemoteLauncher)
-    (w & projectiles %~ IM.delete pjid)
+    (w & props %~ IM.delete pjid)
 retireRemoteRocket itid t pjid w = setScope w 
-    & projectiles . ix pjid . pjUpdate .~ (\_ -> retireRemoteRocket itid (t-1) pjid)
+    & props . ix pjid . pjUpdate .~ (\_ -> retireRemoteRocket itid (t-1) pjid)
   where
     setScope w' = case _itemPositions w' IM.! itid of
         InInv cid invid -> w' 
             & creatures . ix cid . crInv . ix invid . itAttachment 
                     . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
         _   -> w'
-    pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos
+    pos = fromMaybe (V2 0 0) $ w ^? props . ix pjid . pjPos
 retireRemoteBomb :: Int -> Int -> Int -> World -> World
 retireRemoteBomb itid 0 pjid w = w
     & pointToItem (_itemPositions w IM.! itid) %~ 
@@ -768,21 +768,21 @@ retireRemoteBomb itid 0 pjid w = w
         . (itZoom .~ defaultItZoom)
         . (itUse .~ const throwRemoteBomb)
         )
-    & projectiles %~ IM.delete pjid
+    & props %~ IM.delete pjid
 retireRemoteBomb itid t pjid w = setScope w 
-    & projectiles . ix pjid . pjUpdate .~ (\_ -> retireRemoteBomb itid (t-1) pjid)
+    & props . ix pjid . pjUpdate .~ (\_ -> retireRemoteBomb itid (t-1) pjid)
   where
     setScope w' = case _itemPositions w' IM.! itid of
         InInv cid invid -> w' 
             & creatures . ix cid . crInv . ix invid . itAttachment 
                     . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
         _   -> w'
-    pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos
+    pos = fromMaybe (V2 0 0) $ w ^? props . ix pjid . pjPos
 
 moveRemoteBomb :: Int -> Int -> Int -> World -> World
 moveRemoteBomb itid time pID w 
     | time < -4 = updatePicture
-                $ set (projectiles .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (f time) pID)
+                $ set (props .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (f time) pID)
                     w
     | time < 2 = case hitWl of
             Just (p,_) -> soundStart (Tap 0) p tapQuietS Nothing $ halfV updatedWorld
@@ -792,40 +792,40 @@ moveRemoteBomb itid time pID w
             _      -> updatedWorld
   where 
     updatedWorld 
-        = updateV $ set (projectiles . ix pID . pjPos) finalPos
+        = updateV $ set (props . ix pID . pjPos) finalPos
             $ updatePicture
-            $ set (projectiles .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (time-1) pID)
+            $ set (props .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (time-1) pID)
                 w
-    pj     = _projectiles w IM.! pID
+    pj     = _props w IM.! pID
     oldPos = _pjPos pj
     newPos = _pjVel pj +.+ oldPos
     -- this is hacky, should use a version of collidePointWalls' that collides
     -- circles and walls
     invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
-    hitWl  = collideCircWalls'' oldPos newPos 4 $ wallsNearPoint newPos w
+    hitWl  = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
     finalPos = maybe newPos (invShift . fst) hitWl
-    setV v = set (projectiles . ix pID . pjVel) v
+    setV v = set (props . ix pID . pjVel) v
     updateV = maybe id (setV . snd) hitWl
-    halfV = projectiles . ix pID . pjVel %~ (0.5 *.*)
+    halfV = props . ix pID . pjVel %~ (0.5 *.*)
     f x | x < -369 = -10
         | otherwise = x - 1
     updatePicture = 
-        set (projectiles . ix pID . pjDraw)
+        set (props . ix pID . prDraw)
-            (\_ -> onLayer PtLayer $ uncurryV translate newPos $ remoteBombPic time)
+            (\_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate newPos $ remoteBombPic time)
         . lowLightDirected 
             (withAlpha 0.1 red) 
             newPos 
             (50 *.* unitVectorAtAngle (negate $ degToRad (10 * fromIntegral time)))
             [-0.2,-0.15,-0.1,-0.05,0,0.05,0.1,0.15,0.2]
 
-setRemoteScope :: Int -> Projectile -> World -> World
+setRemoteScope :: Int -> Prop -> World -> World
 setRemoteScope itid pj w' = case w' ^? itemPositions . ix itid of
     Just (InInv cid' invid )
         -> w' & creatures . ix cid' . crInv . ix invid . itAttachment 
                 . scopePos .~ (_pjPos pj -.- _crPos (_creatures w' IM.! cid'))
     _   -> w'
 
-setRemoteBombScope :: Int -> Projectile -> World -> World
+setRemoteBombScope :: Int -> Prop -> World -> World
 setRemoteBombScope itid pj w' = case _itemPositions w' IM.! itid of
     InInv cid invid 
         -> w' & creatures . ix cid . crInv . ix invid . itAttachment 
@@ -909,17 +909,18 @@ fireRemoteLauncher cr w = setLocation
     $ resetFire 
     $ resetName 
     $ soundStart (CrWeaponSound cid 0) pos tap4S Nothing
-    $ over projectiles addRemRocket w
+    $ over props addRemRocket w
   where
-    i = IM.newKey $ _projectiles w
+    i = IM.newKey $ _props w
     cid = _crID cr
     dir = _crDir cr
     pos = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) 0)
     addRemRocket = IM.insert i $ Shell 
         { _pjPos = pos
+        , _pjZ   = 20
         , _pjStartPos = pos
         , _pjVel = rotateV dir (V2 1 0)
-        , _pjDraw = remoteShellPic'
+        , _prDraw = remoteShellDraw
         , _pjID = i
         , _pjUpdate = \pj -> decTimMvVel pj . setRemoteScope itid pj . moveRemoteShell cid itid pj
         , _pjAcc = V2 0 0
@@ -941,18 +942,18 @@ fireRemoteLauncher cr w = setLocation
         _ -> w'
     itid = fromMaybe newitid maybeitid
 
-moveRemoteShell :: Int -> Int -> Projectile -> World -> World
+moveRemoteShell :: Int -> Int -> Prop -> World -> World
 moveRemoteShell cid itid pj w 
     | time > 40 = if circOnSomeWall oldPos 4 w
         then doExplosion w
         else w
     | time >= 20 = case thingHit of
         Just _  -> doExplosion w
-        Nothing -> w & projectiles . ix i . pjDir .~ newdir
+        Nothing -> w & props . ix i . pjDir .~ newdir
     | time > -99 = case thingHit of
         Just _  -> doExplosion $ stopSoundFrom (ShellSound i) w
         Nothing -> w & set randGen g
-            & projectiles . ix i %~ 
+            & props . ix i %~ 
                 ( ( pjVel %~ ( (accel +.+) . (frict *.*) ) )
                 . ( pjDir .~ newdir )
                 )
@@ -978,7 +979,7 @@ moveRemoteShell cid itid pj w
     (frict,g)  = randomR (0.6,0.9) $ _randGen w
     (sparkD,_) = randomR (-0.5,0.5) $ _randGen w
     hitCr    = fst <$> collideCircCrsPoint oldPos newPos 4 w
-    hitWl    = fst <$> collideCircWalls'' oldPos newPos 2 (wallsNearPoint newPos w)
+    hitWl    = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
     thingHit = hitCr <|> hitWl
     r1 = _randGen w & evalState (randInCirc 10)
     smokeGen = shellTrailCloud $ addZ 20 $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)
@@ -990,11 +991,11 @@ explodeRemoteRocket
     -> World 
     -> World
 explodeRemoteRocket itid pjid w
-    = set (projectiles . ix pjid . pjUpdate) (\_ -> retireRemoteRocket itid 30 pjid)
+    = set (props . ix pjid . pjUpdate) (\_ -> retireRemoteRocket itid 30 pjid)
-    $ set (projectiles . ix pjid . pjDraw) (const blank)
+    $ set (props . ix pjid . prDraw) (const mempty)
     $ set (itPoint . itUse) (\_ _ -> id)
     $ resetName
-    $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
+    $ makeExplosionAt (_pjPos (_props w IM.! pjid)) w
   where 
     resetName = set (itPoint . itName) "REMOTELAUNCHER"
     itPoint = pointToItem $ _itemPositions w IM.! itid
@@ -1004,14 +1005,14 @@ throwRemoteBomb cr w = setLocation
     $ removePict 
     $ resetFire 
     $ resetName 
-    $ over projectiles addG w
+    $ over props addG w
   where 
     cid = _crID cr
     addG = IM.insert i $ Projectile 
         { _pjPos = p
         , _pjStartPos = p
         , _pjVel = v
-        , _pjDraw = const blank
+        , _prDraw = const mempty
         , _pjID = i
         , _pjUpdate = \_ -> moveRemoteBomb itid 50 i
         }
@@ -1038,14 +1039,14 @@ throwRemoteBomb cr w = setLocation
 
 explodeRemoteBomb :: Int -> Int -> Creature -> World -> World
 explodeRemoteBomb itid pjid cr w
-    = set (projectiles . ix pjid . pjUpdate) (\_ -> retireRemoteBomb itid 30 pjid)
+    = set (props . ix pjid . pjUpdate) (\_ -> retireRemoteBomb itid 30 pjid)
---        $ set (projectiles . ix pjid . pjDraw) (\_ -> blank)
+--        $ set (props . ix pjid . pjDraw) (\_ -> blank)
         $ set (creatures . ix cid . crInv . ix j . itUse) (\_ -> const id)
         $ resetName
         $ resetPict
 --        $ resetScope
-        $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
+        $ makeExplosionAt (_pjPos (_props w IM.! pjid)) w
-        -- - $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w
+        -- - $ makeShrapnelBombAt (_pjPos (_props w IM.! pjid)) w
   where 
     cid = _crID cr
     resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEBOMB"

src/Dodge/Item/Weapon/AutoGun.hs

@@ -15,6 +15,7 @@ import Dodge.Item.Weapon.TriggerType
 import Dodge.SoundLogic.LoadSound
 import Picture
 import Geometry
+import Geometry.Vector3D
 import ShapePicture
 import Shape
 
@@ -64,7 +65,9 @@ autoGun = defaultAutoGun
     }
 autoGunPic :: SPic
 autoGunPic =
-    ( colorSH red $ upperPrismPoly 5 $ rectNESW 4 12 (-4) (-12)
+    ( colorSH red $ prismPoly 
+        (map (addZ 5) $ rectNESW 2 12 (-2) (-12))
+        (map (addZ 0) $ rectNESW 4 12 (-4) (-12))
     , mempty
     )
 

src/Dodge/Item/Weapon/Booster.hs

@@ -9,6 +9,7 @@ import qualified IntMapHelp as IM
 import Dodge.Picture.Layer
 import Picture
 import Dodge.Item.Attachment.Data
+import ShapePicture
 
 import Data.Maybe
 import Control.Lens
@@ -40,7 +41,7 @@ boostSelfL x cr invid w = case boostPoint x cr w of
     cid = _crID cr
     cpos = _crPos cr
     r = _crRad cr
-    pid = fromMaybe (IM.newKey $ _projectiles w) 
+    pid = fromMaybe (IM.newKey $ _props w) 
         (cr ^? crInv . ix invid . itAttachment . itInt)
     crEff p ammoEff = addBoostShockwave pid p (r *.* normalizeV (p -.- cpos)) w
         & creatures . ix cid %~ 
@@ -64,11 +65,11 @@ addBoostShockwave
     -> Point2
     -> World
     -> World
-addBoostShockwave pjid p v w = w & projectiles %~
+addBoostShockwave pjid p v w = w & props %~
     IM.insertWith f pjid thePJ
   where
     thePJ = LinearShockwave
-        { _pjDraw = drawBoostShockwave
+        { _prDraw = drawBoostShockwave
         , _pjID = pjid
         , _pjUpdate = updateLinearShockwave
         , _pjPoints = [(p,v)]
@@ -76,16 +77,16 @@ addBoostShockwave pjid p v w = w & projectiles %~
         }
     f newVal oldVal = newVal & pjPoints %~ (++ _pjPoints oldVal)
 
-updateLinearShockwave :: Projectile -> World -> World
+updateLinearShockwave :: Prop -> World -> World
 updateLinearShockwave pj w
-    | t < 1 = w & projectiles %~ IM.delete pjid
+    | t < 1 = w & props %~ IM.delete pjid
-    | otherwise = w & projectiles . ix (_pjID pj) . pjTimer -~ 1
+    | otherwise = w & props . ix (_pjID pj) . pjTimer -~ 1
   where
     pjid = _pjID pj
     t = _pjTimer pj
 
-drawBoostShockwave :: Projectile -> Picture
+drawBoostShockwave :: Prop -> SPic
-drawBoostShockwave pj = setLayer 1 $ onLayer UPtLayer $ pictures $
+drawBoostShockwave pj = (,) mempty $ setLayer 1 $ onLayer UPtLayer $ pictures $
     theArc ++
     [ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
     , lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -32,7 +32,7 @@ wpRecock = ItInvEffect
     }
   where 
     f _ cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust fOnIt i
-    moveHammerUp HammerDown = HammerReleased
+    moveHammerUp HammerDown     = HammerReleased
     moveHammerUp HammerReleased = HammerUp
     moveHammerUp HammerUp       = HammerUp
     moveHammerUp NoHammer       = NoHammer

src/Dodge/Item/Weapon/Grenade.hs

@@ -5,12 +5,10 @@ import Dodge.Data.SoundOrigin
 import Dodge.Item.Data
 import Dodge.Base
 import Dodge.Zone
-import Dodge.Picture.Layer
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 import Dodge.Item.Attachment.Data
 import Dodge.Item.Draw
-import Dodge.Default.Shell
 --import Dodge.Default
 import Picture
 import Geometry
@@ -19,64 +17,63 @@ import Shape
 
 import Control.Lens
 import qualified Data.IntMap.Strict as IM
---import System.Random
 
-moveGrenade 
+moveGrenade :: Prop -> World -> World
-    :: Int      -- ^ Timer
+moveGrenade pj w
-    -> Float    -- ^ Direction
+    | _pjTimer pj <= 0 = w 
-    -> Int      -- ^ Projectile id
+        & props %~ IM.delete pID 
-    -> World 
+        & (_pjPayload pj) (_pjPos (_props w IM.! pID)) 
-    -> World
+    | otherwise = case collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w of
-moveGrenade 0 _ pID w = over projectiles (IM.delete pID) 
+        Nothing -> w & props . ix pID %~ normalUpdate
-    $ explosion (_pjPos (_projectiles w IM.! pID)) 
+        Just (p,v)  -> w
-    w
+            & soundStart (Tap 0) p tapQuietS Nothing
-  where
+            & props . ix pID %~ ( ( pjPos .~ p ) . ( pjTimer -~ 1 ) . (pjVel .~ v) )
-    pj = _projectiles w IM.! pID
-    explosion = _pjPayload pj
-moveGrenade time dir pID w = case hitWl of
-    Just (p,_) -> soundStart (Tap 0) p tapQuietS Nothing updatedWorld
-    _      -> updatedWorld
   where 
-    updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos
+    pID = _pjID pj
-                            $ set (projectiles .ix pID. pjDraw) 
+    normalUpdate = (pjTimer -~ 1) 
-                    (\ _ -> onLayer PtLayer $ uncurryV translate newPos 
+        . (pjZ %~ (max 0 . (+ _pjVelZ pj))) 
-                                     $ rotate dir $ _spPicture $ grenadePic time)
+        . (pjVelZ -~ 0.1)
-                        $ set (projectiles .ix pID.pjUpdate) (\_ -> moveGrenade (time-1) dir pID) w
+        . ( pjPos .~ newPos )
-    pj     = _projectiles w IM.! pID
     oldPos = _pjPos pj
     newPos = _pjVel pj +.+ oldPos
-    hitWl  = collideCircWalls'' oldPos newPos 4 $ wallsNearPoint newPos w
-    finalPos = maybe newPos fst hitWl
-    setV v = set (projectiles .ix pID.pjVel) v
-    updateV = maybe id (setV . snd) hitWl
-
 
 grenadePic :: Int -> SPic
-grenadePic x = (,) emptySH $ pictures 
+grenadePic time = 
-    [ color (dark $ dark green) $ circleSolid 5
+    ( colorSH (dark $ dark green) $ upperPrismPolyHalf 5 $ polyCirc 3 5
-    , color green $ arc (degToRad $ (179 * fromIntegral x / 50) - 180 ) 
+    , pictures 
-                        (degToRad $ 180 - (179 * fromIntegral x / 50) ) 
+        [ color green $ arc (degToRad $ (179 * fromIntegral time / 50) - 180 ) 
-                        5
+                            (degToRad $ 180 - (179 * fromIntegral time / 50) ) 
-    , translate (-2) 2 $ rotate (pi*0.5) 
+                            5
-        $ scale 0.05 0.05 $ color green $ text $ show $ 1 + quot x 20 
+--        , translate (-2) 2 $ rotate (pi*0.5) 
-    ]
+--            $ scale 0.05 0.05 $ color green $ text $ show $ 1 + quot time 20 
+        ]
+    )
+
+grenadeDraw :: Float -> Prop -> SPic
+grenadeDraw dir prop = translateSPz z $ uncurryV translateSPf p $ rotateSP dir $ grenadePic time
+  where
+    p = _pjPos prop
+    time = _pjTimer prop
+    z = _pjZ prop
 
 throwGrenade 
     :: (Point2 -> World -> World)   -- ^ Payload
     -> Creature
     -> World 
     -> World
-throwGrenade explosion cr w = setWp $ removePict $ over projectiles addG w
+throwGrenade thePayload cr w = setWp $ removePict $ over props addG w
   where 
     n = _crID cr
-    addG = IM.insert i $ defaultShell 
+    addG = IM.insert i $ Bomb 
         { _pjPos = p
-        , _pjStartPos = p
+        , _pjZ = 10
+        , _pjVelZ = 2
         , _pjVel = v
-        , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ _spPicture $ grenadePic 0
+        , _prDraw = grenadeDraw dir
         , _pjID = i
-        , _pjUpdate = \_ -> moveGrenade fuseTime dir i
+        , _pjUpdate = moveGrenade
-        , _pjPayload = explosion
+        , _pjPayload = thePayload
+        , _pjTimer   = fuseTime
         }
     j = _crInvSel cr
     removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> (,) emptySH blank

src/Dodge/Item/Weapon/Launcher.hs

@@ -100,17 +100,17 @@ thrustParam = PjParam
     , _pjMaxParam = 5
     }
 
-pjThrust :: Int -> Projectile -> World -> World
+pjThrust :: Int -> Prop -> World -> World
 pjThrust i = pjEffTimeRange (st,et) doThrust
   where
     et | i == 0 = 36
        | otherwise = 40 - (i * 20)
     st = et - 100
 
-doThrust :: Projectile -> World -> World
+doThrust :: Prop -> World -> World
 doThrust pj w = w
     & randGen .~ g
-    & projectiles . ix i . pjVel    %~ (\v -> accel +.+ frict *.* v)
+    & props . ix i . pjVel    %~ (\v -> accel +.+ frict *.* v)
     & soundContinue (ShellSound i) newPos missileLaunchS (Just 1)
     & makeFlameletTimed (oldPos -.- vel) 0 (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
     & smokeGen
@@ -137,10 +137,10 @@ aRocketWithItemParams
     -> Creature
     -> World
     -> World
-aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
+aRocketWithItemParams it cr w = over props (IM.insert i theShell) w
   where 
     am = _wpAmmo it
-    i = IM.newKey $ _projectiles w
+    i = IM.newKey $ _props w
     pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
     dir = _crDir cr
     ammoMvs pj w' = foldr (\pjP -> _pjMoveParam pjP (_pjIntParam pjP) it cr pj) w' (_amPjParams am)
@@ -149,7 +149,7 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
         , _pjStartPos = pos
         , _pjVel = rotateV dir (V2 1 0)
         , _pjAcc = rotateV dir (V2 3 0)
-        , _pjDraw = _amPjDraw am
+        , _prDraw = _amPjDraw am
         , _pjID = i
         , _pjUpdate = \pj -> ammoMvs pj . decTimMvVel pj . moveShell pj
         , _pjPayload = _amPayload am
@@ -157,7 +157,7 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
         }
 
 moveShell 
-    :: Projectile   -- ^ Projectile id
+    :: Prop   -- ^ Projectile id
     -> World 
     -> World
 moveShell pj w 
@@ -172,21 +172,21 @@ moveShell pj w
     doExplode = w
         & projectileExplosion oldPos 
         & stopSoundFrom (ShellSound i)
-        & projectiles %~ IM.delete i
+        & props %~ IM.delete i
     i = _pjID pj
     oldPos   = _pjPos pj
     vel      = _pjVel pj
     projectileExplosion = _pjPayload pj
     newPos   = oldPos +.+ vel
     hitCr    = fst <$> collideCircCrsPoint oldPos newPos 4 w
-    hitWl    = fst <$> collideCircWalls'' oldPos newPos 2 (wallsNearPoint newPos w)
+    hitWl    = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
     thingHit = hitCr <|> hitWl
 
-reduceSpinBy :: Float -> Projectile -> World -> World
+reduceSpinBy :: Float -> Prop -> World -> World
-reduceSpinBy x pj = projectiles . ix (_pjID pj) .  pjSpin *~ x
+reduceSpinBy x pj = props . ix (_pjID pj) .  pjSpin *~ x
 
-shellPic :: Projectile -> Picture
+shellPic :: Prop -> SPic
-shellPic pj = setDepth 20 . uncurryV translate pos $ rotate (argV accel) basePic
+shellPic pj = (,) mempty $ setDepth 20 . uncurryV translate pos $ rotate (argV accel) basePic
   where
     basePic = color black $ polygon $ map toV2 [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
     accel = _pjAcc pj
@@ -194,8 +194,8 @@ shellPic pj = setDepth 20 . uncurryV translate pos $ rotate (argV accel) basePic
 
 pjEffTimeRange
     :: (Int,Int)
-    -> (Projectile -> World -> World)
+    -> (Prop -> World -> World)
-    -> Projectile
+    -> Prop
     -> World 
     -> World
 pjEffTimeRange (st,et) f pj
@@ -206,8 +206,8 @@ pjEffTimeRange (st,et) f pj
 
 pjEffAtTime 
     :: Int
-    -> (Projectile -> World -> World)
+    -> (Prop -> World -> World)
-    -> Projectile
+    -> Prop
     -> World
     -> World
 pjEffAtTime t f pj
@@ -217,10 +217,10 @@ pjEffAtTime t f pj
 trySpinByCID
     :: Int -- ^ creature id
     -> Int -- ^ Spin amount
-    -> Projectile
+    -> Prop
     -> World 
     -> World
-trySpinByCID cid i pj w = w & projectiles . ix pjid . pjSpin .~ newSpin
+trySpinByCID cid i pj w = w & props . ix pjid . pjSpin .~ newSpin
   where
     pjid = _pjID pj
     dir      = argV $ _pjVel pj

src/Dodge/Item/Weapon/Shell.hs

@@ -4,8 +4,8 @@ import Dodge.Data
 import Geometry.Vector
 
 import Control.Lens
-decTimMvVel :: Projectile -> World -> World
+decTimMvVel :: Prop -> World -> World
-decTimMvVel pj = projectiles . ix pjid %~
+decTimMvVel pj = props . ix pjid %~
     ( (pjTimer -~ 1) 
     . (pjPos   %~ (+.+ vel) )
     . (pjAcc   %~ rotateV rot )

src/Dodge/Item/Weapon/UseEffect.hs

@@ -113,19 +113,19 @@ aTractorBeam
 aTractorBeam col cr w 
     = set (creatures . ix cid . crInv . ix itRef . itUse)
         (\_ -> aTractorBeam ((col + 1) `mod` 10))
-    $ over projectiles (IM.insert i (tractorBeamAt col i pos dir)) w
+    $ over props (IM.insert i (tractorBeamAt col i pos dir)) w
   where 
     i = newProjectileKey w
     cid = _crID cr
     pos = _crPos cr +.+ ((_crRad cr + 10) *.* unitVectorAtAngle dir)
     dir = _crDir cr
     itRef = _crInvSel cr
-tractorBeamAt :: Int -> Int -> Point2 -> Float -> Projectile
+tractorBeamAt :: Int -> Int -> Point2 -> Float -> Prop
 tractorBeamAt colID i pos dir = Projectile
     { _pjPos = pos
     , _pjStartPos = p'
     , _pjVel = d
-    , _pjDraw = const blank
+    , _prDraw = const (mempty,blank)
     , _pjID = i
     , _pjUpdate = \_ -> updateTractor colID 10 i
     }
@@ -137,12 +137,12 @@ tractorBeamAt colID i pos dir = Projectile
 The interaction of this with objects, walls etc needs more thought.  -}
 updateTractor :: Int -> Int -> Int -> World -> World
 updateTractor colID time i w
-    | time > 0 = set (projectiles . ix i . pjUpdate) (\_ -> updateTractor colID (time-1) i) 
+    | time > 0 = set (props . ix i . pjUpdate) (\_ -> updateTractor colID (time-1) i) 
-                    $ set (projectiles . ix i . pjDraw) (const pic)
+                    $ set (props . ix i . prDraw) (const (mempty,mempty))
                     $ over creatures (IM.map tractCr) 
                     $ over floorItems (IM.map tractFlIt) 
                         w
-    | otherwise = over projectiles (IM.delete i) w
+    | otherwise = over props (IM.delete i) w
   where 
     tractCr cr 
         | circOnSeg p1 p2 cP 10
@@ -166,7 +166,7 @@ updateTractor colID time i w
                 iP = _flItPos it
                 m | dist iP p1 < 350 = 1
                   | otherwise        = (410 - dist iP p1) / 60
-    pj = _projectiles w IM.! i
+    pj = _props w IM.! i
     q = _pjVel pj
     p1 = _pjPos pj
     p' = _pjStartPos pj

src/Dodge/LevelGen/Block.hs

@@ -24,10 +24,10 @@ import System.Random
 updateBlocks :: World -> World
 updateBlocks w 
     = (\w' -> seq (_wallsZone w') w') 
-    $ flip (foldr removeFromZone) deadPanes 
+    $ flip (foldl' $ flip removeFromZone) deadPanes 
     $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks 
  where  
-    degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
+    degradeBlocks = deadBlocks `seq` foldl' (flip killBlock) w deadBlocks
     removeFromZone :: Wall -> World -> World
     removeFromZone bl = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID bl))
       where 
@@ -40,7 +40,7 @@ updateBlocks w
 {- | Destroy a block.
 Plays destruction sound and sets to be displayed other walls that were shadowed by this wall. -}
 killBlock :: Wall -> World -> World
-killBlock bl w =  f bl . flip (foldr unshadow) (_blShadows bl) $ w
+killBlock bl w =  f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
   where
     f :: Wall -> World -> World
     f bl'
@@ -84,7 +84,7 @@ pushPointTowardsBy
 pushPointTowardsBy x p ps = do
     xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
     let toAdd p' y = y *.* (p' -.- p)
-    return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
+    return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)
 
 shrinkPolygon 
     :: RandomGen g 
@@ -105,7 +105,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
     | hp <= 0 && null degradability = w
     | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
     | otherwise = w  
-        & wallsZone . znObjects %~ flip (IM.foldr wallInZone) panes
+        & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
         & walls     %~ IM.union panes
   where 
     lns = zip (p:ps) (ps ++ [p])
@@ -128,7 +128,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
     wallInZone wl 
         | uncurry dist (_wlLine wl) <= 2*zoneSize 
             = insertIMInZone x y wlid wl
-        | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
+        | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl)) ips
       where 
         (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
         wlid  = _wlID wl

src/Dodge/Render.hs

@@ -42,16 +42,24 @@ doDrawing pdata w = do
         viewFroms@(V2 vfx vfy) = _cameraViewFrom w
         viewFrom3d = Vector3 vfx vfy 20
         shadV = _pictureShaders pdata
+        lwShad = _lightingWallShadShader pdata
     -- bind as much data into vbos as feasible at this point
-    -- pictures setup
+    -- count mutable vectors setup
-    layerCounts <- UMV.replicate (6*6) 0
+    layerCounts  <- UMV.replicate (6*6) 0
-    shapeCounts <- UMV.replicate 3 (0 :: Int)
+    shapeCounts  <- UMV.replicate 3 (0 :: Int)
-    -- attempt to do this poking in parallel
+    wlwiflCounts <- UMV.replicate 3 (0 :: Int)
-    nWalls <- MP.bindM3 (\ _ a _ -> return a)
+    -- attempt to poke in parallel
-        -- pictures poking
+    MP.bindM3 (\ _ _ _ -> return ())
         ( pokeBindFoldableLayer shadV layerCounts $ worldPictures w )
-        -- poke wall points and colors
+        ( pokeWallsWindowsFloor
-        ( poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol )
+            (shadVBOptr $ _wallTextureShader pdata) 
+            (shadVBOptr $ _windowShader pdata) 
+            (shadVBOptr $ _textureArrayShader pdata)
+            wlwiflCounts
+            wallPointsCol
+            windowPoints
+            (_floorTiles w)
+        )
         ( pokeShape 
             (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
             (_eboPtr $ _shapeEBO pdata)
@@ -62,10 +70,15 @@ doDrawing pdata w = do
     nShapeVs    <- UMV.read shapeCounts 0
     nIndices    <- UMV.read shapeCounts 1
     nSilIndices <- UMV.read shapeCounts 2
+    nWalls <- UMV.read wlwiflCounts 0
+    nWins  <- UMV.read wlwiflCounts 1
+    nFls   <- UMV.read wlwiflCounts 2
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
         [ ( _wallTextureShader pdata, nWalls)
         , (_shapeShader pdata, nShapeVs)
+        , (_windowShader pdata, nWins)
+        , (_textureArrayShader pdata, nFls)
         ]
     bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata)
     bufferSubData
@@ -89,9 +102,13 @@ doDrawing pdata w = do
     clear [ColorBuffer,DepthBuffer]
     depthFunc $= Just Less
     -- draw wall occlusions from the camera's point of view
-    currentProgram $= Just (_shadProg $ _lightingOccludeShader pdata)
+    currentProgram $= Just (_shadProg lwShad)
-    uniform (head $  _shadUnis $ _lightingOccludeShader pdata) $= viewFrom3d
+    uniform (head $  _shadUnis lwShad) $= viewFrom3d
-    drawShader (_lightingOccludeShader pdata) nWalls
+    bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
+    glDrawArrays 
+        (marshalEPrimitiveMode $ _shadPrim lwShad) 
+        0 
+        (fromIntegral nWalls)
     --draw walls onto base buffer
     if w ^. config . wall_textured
         then renderTextureWalls pdata nWalls
@@ -108,9 +125,8 @@ doDrawing pdata w = do
         GL_UNSIGNED_SHORT
         nullPtr
     --draw floor onto base buffer
-    nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
+--    nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
-    bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs]
+    drawShader (_textureArrayShader pdata) nFls
-    drawShader (_textureArrayShader pdata) nTextArrayVs
     --draw lightmap into its own buffer
     bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
     createLightMap pdata lightPoints nWalls nSilIndices nIndices (snd $ snd $ _fboBase pdata)
@@ -154,14 +170,15 @@ doDrawing pdata w = do
     drawBuffers $= [FBOColorAttachment 0,NoBuffers]
     clear [ColorBuffer]
     renderLayer 2 shadV layerCounts
-    renderWindows pdata windowPoints
+    --renderWindows pdata windowPoints
+    drawShader (_windowShader pdata) nWins
     when (_cloud_shadows $ _config w) $ do
         ----render transparency depths
         depthMask $= Enabled
         blend $= Disabled
         drawBuffers $= [NoBuffers,FBOColorAttachment 1]
         renderLayer 2 shadV layerCounts
-        renderWindows pdata windowPoints
+        drawShader (_windowShader pdata) nWins
         ----draw lightmap for cloud buffer
         depthMask $= Disabled
         blend $= Enabled
@@ -247,18 +264,6 @@ renderBlankWalls pdata nWalls = do
     drawShader (_wallBlankShader pdata) nWalls
     cullFace $= Nothing
 
-renderWindows 
-    :: RenderData 
-    -> [((Point2,Point2),Point4)]   -- ^ List: wall positions and color
-    -> IO ()
-renderWindows pdata wps = do
-    n <- poke224s (shadVBOptr $ _windowShader pdata) wps
-    bindShaderBuffers [_windowShader pdata] [n]
-    currentProgram $= Just (_shadProg $ _windowShader pdata)
-    --cullFace $= Just Back
-    drawShader (_windowShader pdata) n
-    --cullFace $= Nothing
-
 renderTextureWalls 
     :: RenderData 
     -> Int   -- ^ number of walls

src/Dodge/Render/Picture.hs

@@ -27,7 +27,7 @@ import qualified Data.Map as M
 worldPictures :: World -> Picture
 worldPictures w = pictures
     [pictures (_decorations w)
-    ,concatMapPic (dbArg _pjDraw)  $ _projectiles w
+    ,concatMapPic (_spPicture . dbArg _prDraw)  $ _props w
     ,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w
     ,concatMapPic (dbArg _ptDraw) $ _particles w
     ,testPic w

src/Dodge/Render/Shape.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.Shape
   where
 import Dodge.Data
+import Dodge.Base
 import Shape
 import Geometry
 --import Color
@@ -11,8 +12,9 @@ import Dodge.Render.ShapePicture
 import qualified Data.IntMap as IM
 worldShape :: World -> Shape
 worldShape w = _foregroundShape w 
-    <> mconcat (map (crShape w) (IM.elems $ IM.filter (pointIsClose . _crPos) (_creatures w)))
+    <> foldMap (crShape w) (IM.elems $ IM.filter (pointIsClose . _crPos) (_creatures w))
-    <> mconcat (map (_spShape . floorItemSPic) $ IM.elems $ IM.filter (pointIsClose . _flItPos) $ _floorItems w)
+    <> (foldMap (_spShape . floorItemSPic) $ IM.elems $ IM.filter (pointIsClose . _flItPos) $ _floorItems w)
+    <> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w)
   where
     pointIsClose p = dist camCen p < winSize
     winSize = 30 + max (getWindowX w) (getWindowY w)

src/Dodge/Update.hs

@@ -118,12 +118,12 @@ updateTriggers w
     cr = _creatures w IM.! 0 & crPos .~ V2 0 0
 
 updateLightSources :: World -> World
-updateLightSources w = set tempLightSources tlss w
+updateLightSources w = over tempLightSources f w
   where 
-    tlss = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
+    f = mapMaybe (\b -> _tlsUpdate b w b)
 
 updateProjectiles :: World -> World
-updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _projectiles w
+updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props w
 {-
 Apply internal particle updates, delete 'Nothing's.  -}
 updateParticles :: World -> World
@@ -151,7 +151,7 @@ ppEvents :: World -> World
 ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w
 
 updateSeenWalls :: World -> World
-updateSeenWalls w = foldr markSeen w wallsToUpdate
+updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate
   where 
     vPos = _cameraViewFrom w
     wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
@@ -224,10 +224,10 @@ clClSpringVel a v b
     radDist = (_clRad a + _clRad b) / 2
 
 simpleCrSprings :: World -> World
-simpleCrSprings w = IM.foldr crSpring w $ _creatures w
+simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
 
 crSpring :: Creature -> World -> World
-crSpring c w = IM.foldr (crCrSpring c) w cs
+crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
   where 
     cs = creaturesNearPoint (_crPos c) w
 

src/Dodge/WallCreatureCollisions.hs

@@ -3,8 +3,8 @@ module Dodge.WallCreatureCollisions
     ( colCrsWalls
     ) where
 import Dodge.Data
-import Dodge.Data.DamageType
+--import Dodge.Data.DamageType
-import Dodge.Creature.State.Data
+--import Dodge.Creature.State.Data
 import Dodge.Zone
 import Dodge.Base
 import Dodge.Config.Data
@@ -50,8 +50,10 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall
 pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature
 pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
     []  -> cr
-    [p] -> cr & crPos .~ p
+    (p:_) -> cr & crPos .~ p
-    _   -> cr & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
+--    (_:p:_)   -> cr 
+--        & crPos .~ p
+--        & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
   where
     cpos = _crPos cr
 

src/Preload/Render.hs

@@ -116,7 +116,7 @@ preloadRender = do
     let silEBO = EBO {_ebo = silEBOname, _eboPtr = silEBOptr}
         shEdgeVAO = VAO { _vao = shEdgeVAOname, _vaoVBO = shVBO }
     -- lighting shaders
-    lightingOccludeShad <- makeShaderUsingVAO "lighting/occlude" [vert,geom,frag] EPoints wpVAO
+    lightingWallShadShad <- makeShaderUsingVAO "lighting/wallShadow" [vert,geom,frag] EPoints wpVAO
                 >>= addUniforms ["lightPos"]
     lightingCapShad
          <- makeShaderUsingVAO "lighting/cap" [vert,geom,frag] ETriangles shPosVAO
@@ -201,7 +201,7 @@ preloadRender = do
         , _silhouetteEBO = silEBO
         , _lightingCapShader        = lightingCapShad
         , _lightingLineShadowShader = lightingLineShadowShad
-        , _lightingOccludeShader    = lightingOccludeShad
+        , _lightingWallShadShader    = lightingWallShadShad
         , _wallBlankShader          = wallBlankShad
         , _wallTextureShader        = wallTextureShad
         , _windowShader             = wallBlankShad { _shadVAO = winColVAO }
@@ -239,6 +239,6 @@ cleanUpRenderPreload :: RenderData -> IO ()
 cleanUpRenderPreload pd = do
     -- TODO fix this
     --mapM_ freeShaderPointers $ _pictureShaders pd
-    freeShaderPointers $ _lightingOccludeShader pd
+    freeShaderPointers $ _lightingWallShadShader pd
     freeShaderPointers $ _fullscreenShader pd
 

src/Render.hs

@@ -38,6 +38,8 @@ createLightMap
 createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
     let llsShad = _lightingLineShadowShader pdata
     let lcShad  = _lightingCapShader pdata
+    let lwShad  = _lightingWallShadShader pdata
+    let flShad  = _fullLightingShader pdata
     -- we assume that the renderbuffer's depth has been correctly set elsewhere
     -- we will not be changing that here
     depthMask $= Disabled
@@ -59,10 +61,15 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
         stencilOpSeparate Back  $= (OpKeep,OpKeep,OpDecrWrap)
         stencilFunc $= (Always, 0, 255)
         --draw wall shadows
-        currentProgram $= Just (_shadProg $ _lightingOccludeShader pdata)
+        currentProgram $= Just (_shadProg lwShad)
-        uniform (head $  _shadUnis $ _lightingOccludeShader pdata)
+        uniform (head $  _shadUnis lwShad)
             $= Vector3 x y z
-        drawShader (_lightingOccludeShader pdata) nWalls
+        bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
+        glDrawArrays 
+            (marshalEPrimitiveMode $ _shadPrim lwShad) 
+            0 
+            (fromIntegral nWalls)
+        --drawShader lwShad nWalls
         --draw silhouette shadows
         currentProgram $= Just (_shadProg llsShad)
         uniform (head $  _shadUnis $ _lightingLineShadowShader pdata)
@@ -91,12 +98,16 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
         colorMask $= Color4 Enabled Enabled Enabled Enabled
         stencilOp $= (OpKeep,OpKeep,OpKeep)
         stencilFunc $= (Equal, 0, 255)
-        currentProgram $= Just (_shadProg $ _fullLightingShader pdata)
+        currentProgram $= Just (_shadProg flShad)
-        uniform (head $  _shadUnis $ _fullLightingShader pdata)
+        uniform (head $  _shadUnis flShad)
             $= Vector3 x y z
-        uniform (_shadUnis (_fullLightingShader pdata) !! 1)
+        uniform (_shadUnis flShad !! 1)
             $= Vector4 r g b rad
-        drawShader (_fullLightingShader pdata) 4
+        bindVertexArrayObject $= Just (_vao $ _shadVAO flShad)
+        glDrawArrays 
+            (marshalEPrimitiveMode (_shadPrim flShad))
+            0 
+            (fromIntegral (4::Int))
     --cleanup: may not be necessary, depending on what comes after...
     cullFace $= Nothing
     stencilTest $= Disabled

src/Shader/Poke.hs

@@ -5,9 +5,9 @@ module Shader.Poke
     , pokeLayVerxs
     , pokeArrayOff
     , pokePoint33s
-    , poke224s
     , pokeShape
     , pokePoint3s
+    , pokeWallsWindowsFloor
     ) where
 import Shader.Data
 import Shader.Parameters
@@ -39,7 +39,7 @@ pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs
 pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
 pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
     typeOff <- UMV.unsafeRead offsets sn
-    basePtr <- _vboPtr . _vaoVBO . _shadVAO <$> MV.read vbos sn
+    basePtr <- _vboPtr . _vaoVBO . _shadVAO <$> MV.unsafeRead vbos sn
     let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
     poke34 thePtr thePos theCol
     pokeArrayOff thePtr 7 ext
@@ -47,6 +47,46 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
   where
     sn = _unShadNum theShadNum
 
+pokeWallsWindowsFloor
+    :: Ptr Float
+    -> Ptr Float
+    -> Ptr Float
+    -> UMV.MVector (PrimState IO) Int
+    -> [ ( (Point2,Point2) , Point4 ) ]
+    -> [ ( (Point2,Point2) , Point4 ) ]
+    -> [ ( Point3          , Point3 ) ]
+    -> IO ()
+pokeWallsWindowsFloor wlptr wiptr flptr counts wls wis fls = do
+    VS.mapM_ (pokeW wlptr counts 0) (VS.fromList wls)
+    VS.mapM_ (pokeW wiptr counts 1) (VS.fromList wis)
+    VS.mapM_ (pokeF flptr counts)   (VS.fromList fls)
+
+pokeF :: Ptr Float -> UMV.MVector (PrimState IO) Int -> (Point3,Point3) -> IO ()
+pokeF ptr counts (V3 a b c,V3 d e f) = do
+    i' <- UMV.unsafeRead counts 2
+    let i = i' * 6
+    pokeElemOff ptr (i + 0) a
+    pokeElemOff ptr (i + 1) b
+    pokeElemOff ptr (i + 2) c
+    pokeElemOff ptr (i + 3) d
+    pokeElemOff ptr (i + 4) e
+    pokeElemOff ptr (i + 5) f
+    UMV.unsafeModify counts (+1) 2
+
+pokeW :: Ptr Float -> UMV.MVector (PrimState IO) Int -> Int -> ((Point2,Point2),Point4) -> IO ()
+pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do
+    i' <- UMV.unsafeRead counts iv
+    let i = i' * 8
+    pokeElemOff ptr (i + 0) a
+    pokeElemOff ptr (i + 1) b
+    pokeElemOff ptr (i + 2) c
+    pokeElemOff ptr (i + 3) d
+    pokeElemOff ptr (i + 4) e
+    pokeElemOff ptr (i + 5) f
+    pokeElemOff ptr (i + 6) g
+    pokeElemOff ptr (i + 7) h
+    UMV.unsafeModify counts (+1) iv
+
 pokeShape
     :: Ptr Float 
     -> Ptr GLushort 
@@ -64,7 +104,7 @@ pokeShapeObj
     -> ShapeObj 
     -> IO ()
 pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
-    TopPrism size -> pokeTopPrism size ptr iptr ieptr counts shVerts
+    TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts
 
 pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort 
     -> Ptr GLushort 
@@ -72,44 +112,37 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
     -> [ShapeV] 
     -> IO ()
 pokeTopPrism size ptr iptr ieptr counts svs = do
---    MP.bindM3 (\a b c -> return (a,b,c))
+    nv <- UMV.unsafeRead counts 0
---        (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) )
+--    MP.bindM3 (\_ _ _ -> return ())
---        (UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     V.! (size - 2)) )
+    UV.mapM_ (pokeTopPrismIndex nv iptr      counts) (memoTopPrismIndices     V.! size)
---        (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) )
+    UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size)
-    nv <- UMV.read counts 0
+    VS.mapM_ (pokeJustV ptr counts)                  (VS.fromList svs)
-    UV.mapM_ (pokeTopPrismIndex nv iptr      counts)  (memoTopPrismIndices     V.! (size - 2))
-    UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! (size - 2))
-    VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs)
---    UMV.modify counts (+ nv') 0
---    UMV.modify counts (+ ni') 1
---    UMV.modify counts (+ nei') 2
-    --return (nv',ni',nei')
 
 pokeTopPrismEdgeIndex :: Int -> Ptr GLushort 
     -> UMV.MVector (PrimState IO) Int 
     -> Int 
     -> IO ()
 pokeTopPrismEdgeIndex nv eiptr counts ioff = do
-    nei <- UMV.read counts 2
+    nei <- UMV.unsafeRead counts 2
     pokeElemOff eiptr nei (fromIntegral $ nv + ioff)
-    UMV.modify counts (+1) 2
+    UMV.unsafeModify counts (+1) 2
 
 pokeTopPrismIndex :: Int -> Ptr GLushort 
     -> UMV.MVector (PrimState IO) Int 
     -> Int 
     -> IO ()
 pokeTopPrismIndex nv iptr counts ioff = do
-    ni <- UMV.read counts 1
+    ni <- UMV.unsafeRead counts 1
     pokeElemOff iptr ni (fromIntegral $ nv + ioff)
-    UMV.modify counts (+1) 1
+    UMV.unsafeModify counts (+1) 1
 
 memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
-memoTopPrismEdgeIndices = V.generate 6 f
+memoTopPrismEdgeIndices = V.generate 10 f
   where
     f n = UV.fromList $ topPrismEdgeIndices (n + 2)
 
 memoTopPrismIndices :: V.Vector (UV.Vector Int)
-memoTopPrismIndices = V.generate 6 f
+memoTopPrismIndices = V.generate 10 f
   where
     f n = UV.fromList $ topPrismIndices (n + 2)
 
@@ -136,7 +169,7 @@ topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
 
 pokeJustV :: Ptr Float -> UMV.MVector (PrimState IO) Int -> ShapeV -> IO ()
 pokeJustV ptr counts sh = do
-    nv <- UMV.read counts 0
+    nv <- UMV.unsafeRead counts 0
     let off i = nv*7 + i
     pokeElemOff ptr (off 0) a
     pokeElemOff ptr (off 1) b
@@ -145,7 +178,7 @@ pokeJustV ptr counts sh = do
     pokeElemOff ptr (off 4) e
     pokeElemOff ptr (off 5) f
     pokeElemOff ptr (off 6) g
-    UMV.modify counts (+1) 0
+    UMV.unsafeModify counts (+1) 0
   where
     V3 a b c    = _svPos sh
     V4 d e f g  = _svCol sh
@@ -226,19 +259,3 @@ pokePoint33 ptr n (V3 a b c,V3 d e f) = do
   where
     off i = n*6 + i
 
-pokePoint224 :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int
-pokePoint224 ptr n ((V2 a b,V2 c d),V4 e f g h) = 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
-    return (n + 1)
-  where
-    off i = n*8 + i
-
-poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
-poke224s ptr = VS.foldlM' (pokePoint224 ptr) 0 . VS.fromList

src/Shape.hs

@@ -4,6 +4,8 @@ module Shape
     , translateSH
     , emptySH
     , upperPrismPoly
+    , upperPrismPolyHalf
+    , prismPoly
     , polyCirc
     , translateSHz
     , translateSHf
@@ -25,6 +27,23 @@ polyCirc :: Int -> Float -> [Point2]
 {-# INLINE polyCirc #-}
 polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/fromIntegral n..]
 
+-- very "unsafe": be careful with the inputs
+-- length of polys must be the same
+-- points should be correctly ordered so that
+-- polys form a prism-like object with quad faces between them
+prismPoly 
+    :: [Point3] 
+    -> [Point3] 
+    -> Shape
+{-# INLINE prismPoly #-}
+prismPoly upps downps = [ShapeObj (TopPrism n) (f upps downps)]
+  where
+    n = length upps
+    f (a:as) (b:bs) = g a:g b:f as bs
+    f [] _ = []
+    f _ [] = []
+    g p = ShapeV p black
+
 upperPrismPoly 
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 
@@ -41,6 +60,22 @@ upperPrismPoly h ps = [ShapeObj (TopPrism n) (f upps downps)]
     f' (V2 x y) = pairToSV (V3 x y h, black)
     f'' (V2 x y) = pairToSV (V3 x y 0, black)
 
+upperPrismPolyHalf
+    :: Float    -- ^ height, expected to be strictly positive
+    -> [Point2] 
+    -> Shape
+{-# INLINE upperPrismPolyHalf #-}
+upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (f upps downps)]
+  where
+    n = length ps
+    upps = map f' ps
+    downps = map f'' ps
+    f (a:as) (b:bs) = a:b:f as bs
+    f [] _ = []
+    f _ [] = []
+    f' (V2 x y) = pairToSV (V3 (0.5 * x) (0.5 * y) h, black)
+    f'' (V2 x y) = pairToSV (V3 x y 0, black)
+
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
 colorSH col = overCol $ const col