Merge branch 'testing', resolved conflicts

src/Dodge/Creature.hs

@@ -253,7 +253,7 @@ startCr = defaultCreature
     , _crMaxHP = 1500
     , _crInv = IM.fromList (zip [0..20] 
          (
-          [pistol,autoGun,launcher,lasGun,grenade
+          [pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade
           ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
           ,longGun
           ,hvAutoGun
@@ -264,10 +264,36 @@ startCr = defaultCreature
           ,bezierGun
           ,poisonSprayer
           ,blinkGun
-          ,frontArmour
-          ] 
+           ] 
+--          [pistol,autoGun,launcher,lasGun,grenade
+--          ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
+--          ,longGun
+--          ,hvAutoGun
+--          ,teslaGun
+--          ,latchkey 0
+--          ,miniGun
+--          ,medkit 50
+--          ,bezierGun
+--          ,poisonSprayer
+--          ,blinkGun
+--          ,frontArmour
+--          ] 
           ++ repeat NoItem)) 
          -- startInv
+--                           ([pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade
+--                            ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
+--                            ,longGun
+--                            ,hvAutoGun
+--                            ,teslaGun
+--                            ,latchkey 0
+--                            ,miniGun
+--                            ,medkit 50
+--                            ,bezierGun
+--                            ,poisonSprayer
+--                            ,blinkGun
+--                            ] 
+--                            ++ repeat NoItem)) 
+--                          -- startInv
     , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
     }
 

src/Dodge/Creature.hs.orig

@@ -0,0 +1,314 @@
+module Dodge.Creature 
+    ( module Dodge.Creature
+    , module Dodge.Creature.Inanimate
+    )
+  where
+-- imports {{{
+import Dodge.Data
+import Dodge.AIs
+import Dodge.CreatureState
+import Dodge.Default
+import Dodge.Base
+import Dodge.Item.Weapon
+import Dodge.Item.Consumable
+import Dodge.WorldEvent.Cloud
+import Dodge.Creature.YourControl
+import Dodge.Creature.Inanimate
+
+import Picture
+import Geometry
+
+import Data.List
+import Data.Char
+import Data.Maybe
+import Data.Function
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.PatriciaTree
+import Codec.BMP
+import qualified Data.ByteString as B
+import Control.Lens
+import Control.Applicative
+import Control.Monad.State
+import Control.Monad
+import System.Random
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+import Foreign.ForeignPtr
+import Control.Concurrent
+
+colouredEnemy col = pictures [color col $ circleSolid 10, circLine 10]
+
+spawnerCrit :: Creature
+spawnerCrit = defaultCreature
+    { _crUpdate = stateUpdate $ spawnerAI chaseCrit
+    , _crHP = 300
+    , _crPict = enemyPict blue
+    , _crState = defaultState {_goals = [[WaitFor 0]]
+                            }
+    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+    }
+smallChaseCrit :: Creature
+smallChaseCrit = defaultCreature
+    { _crUpdate = stateUpdate chaseAI
+    , _crHP = 1
+    , _crRad = 4
+    , _crPict = enemyPict green
+    , _crState = defaultState {_goals = [[Wait]]
+                            ,_faction = ChaseCritters}
+    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4
+    }
+chaseCrit :: Creature
+chaseCrit = defaultCreature
+    { _crUpdate = stateUpdate chaseAI
+    , _crHP = 300
+    , _crPict = enemyPict green
+    , _crState = defaultState {_goals = [[Wait]]
+                            ,_faction = ChaseCritters}
+    , _crInv = IM.empty 
+    }
+armourChaseCrit :: Creature
+armourChaseCrit = defaultCreature
+    { _crUpdate = stateUpdate chaseAI
+    , _crHP = 300
+    , _crPict = enemyPict green
+    , _crState = defaultState {_goals = [[Wait]]}
+    , _crInv = IM.fromList [(0,frontArmour)]
+    }
+miniGunCrit :: Creature
+miniGunCrit = defaultCreature
+    { _crPict = enemyPict red
+    , _crUpdate = stateUpdate  miniAI
+    , _crInv = IM.fromList [(0,miniGun)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crState = defaultState {_goals = [[InitGuard]]}
+    , _crHP = 500
+    }
+longCrit :: Creature
+longCrit = defaultCreature
+    { _crPict = enemyPict red
+    , _crUpdate = stateUpdate sniperAI
+    , _crInv = IM.fromList [(0,longGun),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crState = defaultState {_goals = [[InitGuard]]}
+    , _crHP = 300
+    }
+multGunCrit :: Creature
+multGunCrit = defaultCreature
+    { _crPict = enemyPict red
+    , _crUpdate = stateUpdate (twitchMissAI 300 350)
+    , _crInv = IM.fromList [(0,multGun),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crState = defaultState {_goals = [[InitGuard]]}
+    , _crHP = 300
+    }
+launcherCrit :: Creature
+launcherCrit = defaultCreature
+    { _crPict = enemyPict red
+    , _crUpdate = stateUpdate (launcherAI 150 200)
+    , _crInv = IM.fromList [(0,launcher),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crState = defaultState {_goals = [[Init]]}
+    , _crHP = 300
+    }
+spreadGunCrit :: Creature
+spreadGunCrit = defaultCreature
+    { _crPict = enemyPict red
+    , _crUpdate = stateUpdate chargeAI
+    , _crInv = IM.fromList [(0,spreadGun),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crState = defaultState {_goals = [[Init]]}
+    , _crHP = 300
+    }
+pistolCrit :: Creature
+pistolCrit = defaultCreature
+    { _crPict = enemyPict red
+    , _crUpdate = stateUpdate (dodgeAI 150 200)
+    , _crInv = IM.fromList [(0,pistol),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crState = defaultState {_goals = [[InitGuard]]}
+    , _crHP = 500
+    }
+autoCrit :: Creature
+autoCrit = defaultCreature
+    { _crPict = enemyPict red
+    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crUpdate = stateUpdate  basicShooterAI
+    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    --, _crState = ShooterWait
+    , _crState = defaultState {_goals = [[InitGuard]]}
+    , _crHP = 300
+    }
+addArmour :: Creature -> Creature
+addArmour = over crInv insarmour
+    where insarmour xs = IM.insert i frontArmour xs
+            where i = newKey xs
+
+equipOnTop :: (Creature -> Picture) -> Creature -> Picture
+--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
+equipOnTop f cr = pictures [onLayer CrLayer (f cr) , drawEquipment cr]
+
+drawEquipment :: Creature -> Picture
+drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
+    where f (i,it) = case it ^? itEquipPict of
+                        Just g -> g cr i
+                        _      -> blank
+
+--drawEquipment :: Creature -> ([Picture],[Picture])
+--drawEquipment cr = (map fst p1, map fst p2)
+--     where f (k,it) = join $ (it ^? itEquipPict) <*> (pure cr) <*> (pure k)
+--           picts = sortBy (compare `on` snd) $ mapMaybe f $ IM.toList (_crInv cr)
+--           (p1,p2) = partition (\ x -> snd x < 0) picts
+
+frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20
+                             , color red $ circLine 20
+                             ]
+
+--packCrits :: (Int -> World -> World) -> [Int] -> [Creature]
+--packCrits ai is = [(defaultCreature i)
+--    { _crPos = (150,10+20*fromIntegral i)
+--    , _crPict = swarmPict
+--    , _crUpdate = ai i
+--    --, _crUpdate = swarmAI is i
+--    , _crRad = 3
+--    , _crHP = 1
+--    , _crMass = 2
+--    }
+--    | i <- is]
+
+--queenBeeCrit :: Int -> Creature
+--queenBeeCrit cID = (defaultCreature cID)
+--    { _crRad = 20
+--    , _crCorpse = color (greyN 0.5) $ circleSolid 20
+--    , _crPict = const $ pictures [color black $ circSolid 20
+--                         ,color yellow $ circLine 20
+--                         ]
+--    , _crUpdate = checkDead cID . makeStateAI queenBeeAI cID
+--    , _crState = QueenBee 0 20
+--    , _crMass = 20
+--    }
+
+--antCrit :: Int -> Creature
+--antCrit cID = (defaultCreature cID)
+--    { _crPos = (0,100 + 3 * fromIntegral cID)
+--    , _crUpdate = checkDead cID . makeStateAI (antAI 2) cID
+--    , _crState = AntMove 50
+--    , _crPict = antPic
+--    , _crRad = 3
+--    , _crHP = 1
+--    , _crMass = 2
+--    , _crCorpse = color (greyN 0.5) $ circSolid 3
+--    }
+--    where i = evalState (state (randomR (1::Int,100))) (mkStdGen cID)
+--antPic = const $ pictures [ translate (-1) 0 $ circleSolid 2
+--                  , translate (2) 0 $ circleSolid 1
+--                  , translate (1) 0 $ circleSolid 1
+--                  , line [(3,3),(-3,-3)]
+--                  , line [(-3,3),(3,-3)]
+--                  , line [(0,-3),(0,3)]
+--                  ]
+
+flamerPict = const $ pictures [color (light $ light $ light $ dim blue) $ circleSolid 10, circLine 10]
+
+
+
+goalPict cr = let r = _crRad cr in case _crState cr of
+    CrSt {_goals = gls ,_crDamage = crDam } 
+--            | crDam > _crHP cr -> color white $ circleSolid r
+            | otherwise        -> case head gls of
+                        [] -> sizeColEnemy r white
+                        (MoveToFor p i:_) -> dGoals $ sizeColEnemy r green
+                        (WaitFor x:_) -> dGoals $ sizeColEnemy r yellow
+                        (FireAt p:_) -> dGoals $ sizeColEnemy r red
+                        (Reload:_) -> dGoals $ sizeColEnemy r orange
+                        (PathTo p:_) -> dGoals $ sizeColEnemy r cyan
+                        (SubPathTo p i _:_) -> dGoals $ sizeColEnemy r blue
+                        (Search i:_) -> dGoals $ sizeColEnemy r black
+                        _ -> dGoals $ sizeColEnemy r magenta
+                    where dGoals p = pictures [p, rotate (0 - _crDir cr) $ scale 0.1 0.1 $ color white $ text $ show gls]
+    _                  -> sizeColEnemy r (light $ dim green)
+
+startCr :: Creature
+startCr = defaultCreature
+    { _crPos = (0,0)
+    , _crOldPos = (0,0)
+    , _crDir = 0
+    , _crID = 0
+    , _crPict = basicCrPict $ greyN 0.8
+                
+    , _crUpdate = stateUpdate yourControl
+    , _crRad = 10
+    , _crMass = 10
+    , _crHP = 10000
+    , _crMaxHP = 1500
+    , _crInv = IM.fromList (zip [0..20] 
+<<<<<<< HEAD:src/Dodge/Creature.hs
+         (
+          [pistol,autoGun,launcher,lasGun,grenade
+          ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
+          ,longGun
+          ,hvAutoGun
+          ,teslaGun
+          ,latchkey 0
+          ,miniGun
+          ,medkit 50
+          ,bezierGun
+          ,poisonSprayer
+          ,blinkGun
+          ,frontArmour
+          ] 
+          ++ repeat NoItem)) 
+         -- startInv
+=======
+                           ([pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade
+                            ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
+                            ,longGun
+                            ,hvAutoGun
+                            ,teslaGun
+                            ,latchkey 0
+                            ,miniGun
+                            ,medkit 50
+                            ,bezierGun
+                            ,poisonSprayer
+                            ,blinkGun
+                            ] 
+                            ++ repeat NoItem)) 
+                          -- startInv
+>>>>>>> testing:src/Dodge/Critters.hs
+    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
+    }
+
+smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor
+
+enemyPict :: Color -> Creature -> Picture
+enemyPict col = equipOnTop $ sizeEnemy (light $ light $ light $ light col)
+
+sizeEnemy col cr 
+    | pdam > 200      = color red $ circleSolid $ _crRad cr
+    | pdam > 100      = color white $ circleSolid $ _crRad cr
+    | mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
+    | otherwise       = pictures [color col $ circleSolid $ _crRad cr
+                                 , circLine $ _crRad cr ]
+    where pdam = _crPastDamage $ _crState cr
+
+sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r]
+
+basicCrPict :: Color -> Creature -> Picture
+basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr]
+    where naked | pdam > 200      = color red $ circleSolid $ _crRad cr
+                | pdam > 100      = color white $ circleSolid $ _crRad cr
+                | mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
+                -- | crDam > _crHP cr && odd (crDam - _crHP cr)
+                --     = [color white $ circleSolid $ _crRad cr]
+                | otherwise        =  pictures [color col $ circleSolid $ _crRad cr, circLine $ _crRad cr]
+          pdam = _crPastDamage $ _crState cr

src/Dodge/Creature/YourControl.hs

@@ -24,17 +24,16 @@ yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,
 yourControl w (f,g) cr = ( (updateUsingInput . f, g)
                          , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
                          )
-    where strafeSpeed = 8 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
-          speed = 3 * equipFactor
+    where strafeSpeed = _varMovementSpeedModifier w * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
+          speed = _varMovementSpeedModifier w * equipFactor
           equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0
 
 wasdWithAiming :: World -> Float -> Float -> Int -> Creature -> Creature
 wasdWithAiming w speed aimSpeed i cr
     | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming
-        && diffAngles mouseDir (argV mov) < pi/3
+            && diffAngles mouseDir (argV mov) < pi/3
         = over crPos (+.+ (0.2 *.* mov)) 
---          $ set ( creatures . ix i . crDir) (argV mov) 
-          $ set crDir mouseDir 
+          . set crDir mouseDir 
           $ set (crState . stance . carriage) (Boosting mov)
           cr
     | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming
@@ -43,9 +42,7 @@ wasdWithAiming w speed aimSpeed i cr
           cr
     | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving
         = over crPos (+.+ (0.2 *.* mov)) 
---          $ set ( creatures . ix i . crDir) (argV mov) 
-        --  $ set ( creatures . ix i . crDir) mouseDir 
-          $ over crDir (flip fromMaybe dir) 
+          . over crDir (flip fromMaybe dir) 
           $ set (crState . stance . carriage) (Boosting mov)
           cr
     | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isAiming
@@ -56,20 +53,17 @@ wasdWithAiming w speed aimSpeed i cr
         = set (crState . stance . carriage) Floating
           cr
     | isAiming
-        = -- stopSoundFrom (CrSound i) $
-                        stepForward' aimSpeed
-                        $ over crPos (+.+ (aimSpeed *.* mov)) 
-                        $ set crDir mouseDir 
-                        cr
+        = stepForward' aimSpeed
+          $ over crPos (+.+ (aimSpeed *.* mov)) 
+          $ set crDir mouseDir 
+          cr
     | isMoving
-        = -- continueOrLoopFrom (CrSound i) twoStepSound $
-                        stepForward' speed
-                        $ over ( crPos) (+.+ (speed *.* mov)) 
-                        $ over ( crDir) (flip fromMaybe dir) 
-                        cr
+        = stepForward' speed
+          $ over ( crPos) (+.+ (speed *.* mov)) 
+          $ over ( crDir) (flip fromMaybe dir) 
+          cr
     | otherwise
-        = -- stopSoundFrom (CrSound i) $ 
-            over ( crDir) (flip fromMaybe dir) 
+        = over ( crDir) (flip fromMaybe dir) 
                         cr
     where (mov',dir') = wasdComp (view keys w) w
           (mov,dir)   = (rotateV (_cameraRot w) mov',fmap (_cameraRot w +) dir')
@@ -90,13 +84,9 @@ wasdM w scancode
  | scancode == moveRightKey (_keyConfig w) = (1,0)
  | scancode == moveLeftKey (_keyConfig w) = (-1,0)
 wasdM _ _          = (0,0)
---wasdM SDL.ScancodeW = (0,1)
---wasdM SDL.ScancodeS = (0,-1)
---wasdM SDL.ScancodeD = (1,0)
---wasdM SDL.ScancodeA = (-1,0)
---wasdM _          = (0,0)
 
 wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float)
 wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks
     where f (0,0) = ((0,0), Nothing)
           f p     = (errorNormalizeV 46 p, Just $ argV p)
+

src/Dodge/Data.hs

@@ -74,6 +74,8 @@ data World = World
     , _seenLocations        :: IM.IntMap (World -> Point2,String)
     , _selLocation          :: Int
     , _keyConfig            :: KeyConfigSDL
+    , _varMovementSpeedModifier :: Float
+    , _varMovementStrafeSpeedModifier :: Float
     } 
 
 data Corpse = Corpse
@@ -109,11 +111,11 @@ data Cloud = Cloud
     }
 
 data LightSource = LS  
-    { _lsID :: !Int
-    , _lsPos :: !Point2
-    , _lsDir :: !Float
-    , _lsRad :: !Float
-    , _lsIntensity :: !Float
+    { _lsID         :: !Int
+    , _lsPos        :: !Point2
+    , _lsDir        :: !Float
+    , _lsRad        :: !Float
+    , _lsIntensity  :: !Float
     }
 
 data TempLightSource = TLS 
@@ -475,14 +477,24 @@ type HitEffect = Particle' -> [(Point2, (Either3 Creature Wall ForceField))] ->
                     -> (World,Maybe Particle')
 
 
-data Projectile = Projectile    
-    { _ptPos :: Point2
-    , _ptStartPos :: Point2
-    , _ptVel :: Point2
-    , _ptPict :: Picture
-    , _ptID :: Int
-    , _ptUpdate :: World -> World
-    }
+data Projectile 
+    = Projectile    
+        { _ptPos :: Point2
+        , _ptStartPos :: Point2
+        , _ptVel :: Point2
+        , _ptPict :: Picture
+        , _ptID :: Int
+        , _ptUpdate :: World -> World
+        }
+    | Shell 
+        { _ptPos :: Point2
+        , _ptStartPos :: Point2
+        , _ptVel :: Point2
+        , _ptPict :: Picture
+        , _ptID :: Int
+        , _ptUpdate :: World -> World
+        , _ptExplosion :: Point2-> World -> World
+        }
 
 data DamageType
     = Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }

src/Dodge/Data.hs.orig

@@ -0,0 +1,691 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data 
+    ( module Dodge.Data
+    , Point2 (..)
+    , Sound (..)
+    , soundTime
+    )
+  where
+import Picture.Data
+import Geometry.Data
+import Sound.Preload
+import Control.Lens
+import Control.Monad.State
+import System.Random
+import Data.Graph.Inductive
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+import qualified SDL.Mixer as Mix
+import SDL (Scancode, MouseButton)
+import Graphics.Rendering.OpenGL (PrimitiveMode (..),GLfloat,Program,VertexArrayObject,BufferObject)
+import Codec.Picture (Image,PixelRGBA8)
+import qualified Data.DList as DL
+import Dodge.LoadConfig
+
+data World = World 
+    { _keys                 :: !(S.Set Scancode)
+    , _mouseButtons         :: !(S.Set MouseButton)
+    , _cameraCenter         :: !Point2
+    , _cameraRot            :: !Float
+    , _cameraZoom           :: !Float
+    , _cameraViewFrom       :: !Point2
+    , _creatures            :: IM.IntMap Creature
+    , _creaturesZone        :: IM.IntMap (IM.IntMap (IM.IntMap Creature))
+    , _itemPositions        :: IM.IntMap ItemPos
+    , _clouds               :: IM.IntMap Cloud
+    , _cloudsZone           :: IM.IntMap (IM.IntMap (IM.IntMap Cloud))
+    , _projectiles          :: IM.IntMap Projectile
+    , _particles'           :: ![Particle']
+    , _walls                :: !(IM.IntMap Wall)
+    , _wallsZone            :: (IM.IntMap (IM.IntMap (IM.IntMap Wall)))
+    , _forceFields          :: IM.IntMap ForceField
+    , _floorItems           :: IM.IntMap FloorItem
+    , _randGen              :: StdGen
+    , _mousePos             :: !(Float,Float)
+    , _testString           :: String
+    , _yourID               :: !Int
+    , _worldEvents          :: !(World -> World)
+    , _pressPlates          :: IM.IntMap PressPlate
+    , _buttons              :: IM.IntMap Button
+    , _soundQueue           :: [Int]
+    , _sounds               :: M.Map SoundOrigin Sound
+    , _decorations          :: IM.IntMap Picture
+    , _corpses              :: IM.IntMap (IM.IntMap [Corpse])
+    , _clickMousePos        :: (Float,Float)
+    , _pathGraph            :: ~(Gr Point2 Float)
+    , _pathGraph'           :: ~[(Point2,Point2)]
+    , _pathPoints           :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
+    , _pathInc              :: ~(M.Map Point2 [Point2])
+    , _storedLevel          :: Maybe World
+    , _menuState            :: MenuState
+    , _worldState           :: M.Map WorldState Bool
+    , _windowX              :: !Float
+    , _windowY              :: !Float
+    , _carteDisplay         :: !Bool
+    , _carteCenter          :: !Point2
+    , _carteZoom            :: !Float
+    , _carteRot             :: !Float
+    , _lightSources         :: !(IM.IntMap LightSource)
+    , _tempLightSources     :: ![TempLightSource]
+    , _closeActiveObjects   :: [Either FloorItem Button]
+    , _seenLocations        :: IM.IntMap (World -> Point2,String)
+    , _selLocation          :: Int
+    , _keyConfig            :: KeyConfigSDL
+    , _varMovementSpeedModifier :: Float
+    , _varMovementStrafeSpeedModifier :: Float
+    } 
+
+data Corpse = Corpse
+    { _cpPos :: Point2
+    , _cpPict :: Picture
+    , _cpRes :: Creature
+    }
+
+data Layer 
+    = PtLayer 
+    | CrLayer 
+    | WlLayer 
+    | BgLayer 
+    | ShadowLayer 
+    | FlItLayer 
+    | LabelLayer 
+    | InvLayer 
+    | MenuLayer
+    | PressPlateLayer 
+    | CorpseLayer
+    | UPtLayer
+    | HPtLayer
+    | GloomLayer
+
+data Cloud = Cloud
+    { _clID :: Int
+    , _clPos :: Point2
+    , _clVel :: Point2
+    , _clPict :: Cloud -> Picture
+    , _clRad :: Float
+    , _clTimer :: Int
+    , _clEffect :: Cloud -> World -> World
+    }
+
+data LightSource = LS  
+    { _lsID :: !Int
+    , _lsPos :: !Point2
+    , _lsDir :: !Float
+    , _lsRad :: !Float
+    , _lsIntensity :: !Float
+    }
+
+data TempLightSource = TLS 
+    { _tlsPos :: !Point2
+    , _tlsRad :: !Float
+    , _tlsIntensity :: !Float
+    , _tlsUpdate :: World -> TempLightSource -> (World, Maybe TempLightSource)
+    }
+
+data Creature = Creature
+    { _crPos :: Point2
+    , _crOldPos :: Point2
+    , _crDir :: Float
+    , _crID :: Int
+    , _crPict :: Creature -> Picture
+    , _crUpdate :: World -> (World -> World,StdGen) -> Creature 
+                -> ((World -> World,StdGen), Maybe Creature)
+    , _crRad :: Float
+    , _crMass :: Float
+    , _crHP :: Int
+    , _crMaxHP :: Int
+    , _crInv :: IM.IntMap Item
+    , _crInvSel :: Int
+    , _crState :: CreatureState
+    , _crCorpse :: Picture
+    }
+
+data CreatureState = CrSt 
+    { _goals    :: [[Goal]]
+    , _stance  :: Stance
+    , _faction :: Faction
+    , _crDamage  :: [DamageType]
+    , _crPastDamage :: Int
+    , _crSpState :: CrSpState
+    , _crApplyDamage :: [DamageType] -> Creature -> (World -> World,Creature)
+    }
+
+data CrSpState 
+    = Barrel { _piercedPoints :: [Point2]}
+    | GenCr
+  deriving (Eq,Show,Ord)
+data Goal 
+    = MoveTo Point2
+    | MoveToFor Point2 Int
+    | MoveFire Point2 Point2
+    | PathTo Point2
+    | PathAlong [Point2]
+    | SubPathTo Point2 Int Point2
+    | Wait
+    | WaitFor Int
+    | WaitForID Int Int
+    | FireAt Point2
+    | FireAtID Int Point2
+    | Fire
+    | Reload
+    | IncreaseAlert Int
+    | Guard Point2 Point2
+    | Search Int
+    | SearchNear Point2
+    | AimAt Point2 Int
+    | InitGuard
+    | Init
+    | MeleeAttack Int
+    | InitTrackYou
+    | TrackYou
+    | Track Int
+    | TrackFor Int Int
+    | TurnByFor Float Int
+    | TurnTo Point2
+    | TurnToward Point2
+    | TurnTowardAngle Float
+    | StrafeLeftAround Int Point2
+    | StrafeRightAround Int Point2
+    | StrafeLeftFor Int
+    | StrafeRightFor Int
+    | StrafeLeftForSpeed Int Float
+    | StrafeRightForSpeed Int Float
+    | StrafeLeftFire
+    | StrafeRightFire
+    | MoveForwardFor Int
+    | MoveForwardFire
+    | MoveBackwardFor Int
+    | MoveByFor Point2 Int
+    | MoveBackwardFire
+    | GoalID Int Goal
+    | AtRange Float
+    | AtRanges Float Float
+    | RepeatAction Int Goal
+    | MakeJudgement
+    | SetPosture Posture
+  deriving (Eq,Show)
+data Stance = Stance 
+    {_carriage :: Carriage
+    ,_posture  :: Posture
+    }
+  deriving (Eq,Show)
+data Carriage 
+    = Walking { _stepCycle :: Int, _stepToAdd :: Int }
+    | Floating
+    | Boosting Point2
+  deriving (Eq,Show)
+data Posture = Aiming | AtEase
+  deriving (Eq,Show)
+data Mind = ZombieMind | HumanMind
+    deriving (Eq,Show)
+data Faction 
+    = GenericFaction Int
+    | ZombieFaction
+    | EncircleFlock
+    | ChaseCritters
+    | SpawnedBy Int
+    | NoFaction
+  deriving (Eq,Show)
+
+-- NOTE: walls must be drawn counterclockwise
+data WorldState = DoorNumOpen Int | CrNumAlive Int
+  deriving (Eq,Ord)
+
+data MenuState 
+    = LevelMenu Int
+    | PauseMenu
+    | GameOverMenu
+    | InGame
+  deriving (Eq,Ord)
+
+data Button = Button 
+    { _btPict :: Picture
+    , _btPos :: Point2
+    , _btRot :: Float
+    , _btEvent :: Button -> World -> World
+    , _btID :: Int
+    , _btText :: String
+    , _btState :: ButtonState
+    }
+
+data ButtonState = BtOn | BtOff | BtNoLabel
+  deriving (Eq, Show)
+
+data PressPlate = PressPlate 
+    { _ppPict :: Picture
+    , _ppPos :: Point2
+    , _ppRot :: Float
+    , _ppEvent :: PressPlate -> World -> World
+    , _ppID :: Int
+    , _ppText :: String
+    }
+
+data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int}
+
+data ItemPos 
+    =  InInv   { _itCrId :: Int , _itInvId :: Int }
+    | OnFloor  { _itFlID :: Int }
+
+data Item 
+    = Weapon
+        { _itName :: String
+        , _wpMaxAmmo :: Int
+        , _wpLoadedAmmo :: Int
+        , _wpReloadTime :: Int
+        , _wpReloadState :: Int
+        , _wpFireRate :: Int
+        , _wpFireState :: Int
+        , _wpFire :: Int -> World -> World
+        , _wpSpread :: Float
+        , _wpRange :: Float
+        , _itHammer :: HammerPosition
+        , _itFloorPict :: Picture
+        , _itMaxStack :: Int
+        , _itAmount :: Int
+        , _itAimingSpeed :: Float
+        , _itAimingRange :: Float
+        , _itZoom :: ItZoom
+        , _itEquipPict :: Creature -> Int -> Picture
+        , _itScrollUp :: Int -> World -> World
+        , _itScrollDown :: Int -> World -> World
+        , _itIdentity :: ItemIdentity
+        , _itAttachment :: Maybe ItAttachment
+        , _itID :: Maybe Int
+        , _itEffect :: ItEffect
+        , _itInvDisplay :: Item -> String
+        , _itInvColor :: Color
+        }
+    | Consumable
+        { _itName :: String
+        , _itMaxStack :: Int
+        , _itAmount :: Int
+        , _cnEffect :: Int -> World -> Maybe World
+        , _itFloorPict :: Picture
+        , _itEquipPict :: Creature -> Int -> Picture
+        , _itIdentity :: ItemIdentity
+        , _itID :: Maybe Int
+        , _itInvDisplay :: Item -> String
+        , _itInvColor :: Color
+        , _itEffect :: ItEffect
+        , _itHammer :: HammerPosition
+        }
+    | Craftable
+        { _itName :: String
+        , _itMaxStack :: Int
+        , _itAmount :: Int
+        , _itFloorPict :: Picture
+        , _itEquipPict :: Creature -> Int -> Picture
+        , _itIdentity :: ItemIdentity
+        , _itID :: Maybe Int
+        , _itInvDisplay :: Item -> String
+        , _itInvColor :: Color
+        }
+     | Equipment
+        { _itName :: String
+        , _itMaxStack :: Int
+        , _itAmount :: Int
+        , _itFloorPict :: Picture
+        , _itEquipPict :: Creature -> Int -> Picture
+        , _itIdentity :: ItemIdentity
+        , _itEffect :: ItEffect
+        , _itID :: Maybe Int
+        , _itAimingSpeed :: Float
+        , _itAimingRange :: Float
+        , _itZoom :: ItZoom
+        , _itInvDisplay :: Item -> String
+        , _itInvColor :: Color
+        , _itHammer :: HammerPosition
+        }
+     | Throwable
+        { _itName :: String
+        , _itMaxStack :: Int
+        , _itAmount :: Int
+        , _itFloorPict :: Picture
+        , _twMaxRange :: Float
+        , _twAccuracy :: Float
+        , _twFire :: Int -> World -> World
+        , _itAimingSpeed :: Float
+        , _itAimingRange :: Float
+        , _itZoom :: ItZoom
+        , _itEquipPict :: Creature -> Int -> Picture
+        , _itIdentity :: ItemIdentity
+        , _itID :: Maybe Int
+        , _itAttachment :: Maybe ItAttachment
+        , _itInvDisplay :: Item -> String
+        , _itInvColor :: Color
+        , _itEffect :: ItEffect
+        , _itHammer :: HammerPosition
+        , _itScrollUp :: Int -> World -> World
+        , _itScrollDown :: Int -> World -> World
+        }
+     | NoItem
+
+data ItAttachment 
+    = ItScope 
+        {_scopePos        :: Point2
+        ,_scopeZoomChange :: Int
+        ,_scopeZoom       :: Float 
+        ,_scopeIsCamera   :: Bool
+        }
+    | ItFuse {_itFuseTime :: Int}
+    | ItPhaseV {_itPhaseV :: Float}
+    | ItMode {_itMode :: Int}
+    | ItTargetPos { _itTargetPos :: Point2 }
+
+data ItEffect = NoItEffect
+    | ItInvEffect 
+        {_itInvEffect       :: Creature -> Int -> World -> World
+        ,_itEffectCounter   :: Int
+        }
+    | ItEffect 
+        {_itInvEffect       :: Creature -> Int -> World -> World 
+        ,_itFloorEffect     :: Int -> World -> World 
+        ,_itEffectCounter   :: Int
+        }
+data ItZoom = ItZoom 
+    {_itAimZoomMax :: Float
+    ,_itAimZoomMin :: Float
+    ,_itAimZoomFac :: Float
+    ,_itZoomMax    :: Float
+    ,_itZoomMin    :: Float
+    ,_itZoomFac    :: Float 
+    }
+
+data IntID a = IntID Int a
+
+data HammerPosition 
+    = HammerDown
+    | HammerReleased
+    | HammerUp
+    | NoHammer
+
+data ItemIdentity 
+    = Pistol
+    | SpreadGun
+    | MultGun
+    | HvAutoGun
+    | AutoGun
+    | LtAutoGun
+    | MiniGun
+    | Medkit25
+    | MagShield
+    | FrontArmour
+    | JetPack
+    | FlameShield
+    | Generic
+    | SparkGun
+    | ShatterGun
+    | LongGun
+    | Flamethrower
+    | Blinker
+    | Grenade
+    | RemoteBomb
+    | TeslaGun
+    | LasGun
+    | ForceFieldGun
+    | GrapGun
+    | TractorGun 
+    | Launcher
+    | RemoteLauncher
+    | LightningGun
+    | PoisonSprayer
+    deriving (Eq,Show,Ord,Enum)
+
+data Particle' 
+    = Particle' 
+        { _ptDraw :: Particle' -> Picture
+        , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
+        }
+    | Bul'  
+        { _ptDraw :: Particle' -> Picture
+        , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
+        , _btVel' :: Point2
+        , _btColor' :: Color
+        , _btTrail' :: [Point2]
+        , _btPassThrough' :: Maybe Int
+        , _btWidth' :: Float 
+        , _btTimer' :: Int
+        , _btHitEffect' :: HitEffect
+        }
+    | Pt'  
+        { _ptDraw :: Particle' -> Picture
+        , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
+        , _btVel' :: Point2
+        , _btColor' :: Color
+        , _btPos' :: Point2
+        , _btPassThrough' :: Maybe Int
+        , _btWidth' :: Float 
+        , _btTimer' :: Int
+        , _btHitEffect' :: HitEffect
+        }
+    | Shockwave' 
+        { _ptDraw       :: Particle' -> Picture
+        , _ptUpdate'    :: World -> Particle' -> (World, Maybe Particle')
+        , _btColor'     :: Color
+        , _btPos'       :: Point2
+        , _btRad'       :: Float
+        , _btDam'       :: Int
+        , _btPush'      :: Float
+        , _btMaxTime'   :: Int
+        , _btTimer'     :: Int
+        }
+
+type HitEffect = Particle' -> [(Point2, (Either3 Creature Wall ForceField))] -> World 
+                    -> (World,Maybe Particle')
+
+
+<<<<<<< HEAD
+data Projectile = Projectile    
+    { _ptPos :: Point2
+    , _ptStartPos :: Point2
+    , _ptVel :: Point2
+    , _ptPict :: Picture
+    , _ptID :: Int
+    , _ptUpdate :: World -> World
+    }
+
+data DamageType
+    = Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+    | Blunt    {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } 
+    | SparkDam {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } 
+    | Flaming  {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+    | Lasering {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+    | Concussive 
+        { _dmAmount :: Int 
+        , _dmFrom :: Point2 
+        , _dmPush :: Float 
+        , _dmPushExp :: Float
+        , _dmPushRadius :: Float
+        }
+    | TorqueDam {_dmAmount :: Int , _dmTorque :: Float }
+    | PushDam   {_dmAmount :: Int , _dmPushBack :: Point2 }
+    | PoisonDam {_dmAmount :: Int}
+  deriving (Eq,Ord,Show)
+=======
+data Projectile = Projectile    { _ptPos :: Point2
+                                , _ptStartPos :: Point2
+                                , _ptVel :: Point2
+                                , _ptPict :: Picture
+                                , _ptID :: Int
+                                , _ptUpdate :: World -> World
+                                }
+                | Shell { _ptPos :: Point2
+                                , _ptStartPos :: Point2
+                                , _ptVel :: Point2
+                                , _ptPict :: Picture
+                                , _ptID :: Int
+                                , _ptUpdate :: World -> World
+                                , _ptExplosion :: Point2-> World -> World
+                                }
+
+data DamageType = Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+                | Blunt    {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } 
+                | SparkDam {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } 
+                | Flaming  {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+                | Lasering {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+                | Concussive {_dmAmount :: Int , _dmFrom :: Point2 , _dmPush :: Float 
+                                                                  , _dmPushExp :: Float
+                                                                  , _dmPushRadius :: Float}
+                | TorqueDam {_dmAmount :: Int , _dmTorque :: Float }
+                | PushDam   {_dmAmount :: Int , _dmPushBack :: Point2 }
+                | PoisonDam {_dmAmount :: Int}
+    deriving (Eq,Ord,Show)
+>>>>>>> testing
+
+data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
+
+data WLID = WLID { _wlIDx :: Int, _wlIDy :: Int, _wlIDid :: Int}
+
+data Wall 
+    = Wall 
+        { _wlLine :: [Point2] , _wlID :: Int 
+        , _wlColor :: Color
+        , _wlDraw :: Maybe (Wall -> Picture)
+        , _wlSeen :: Bool
+        , _wlIsSeeThrough :: Bool
+        }
+    | BlockAutoDoor 
+        { _wlLine :: [Point2] 
+        , _wlID :: Int 
+        , _doorMech :: World -> World
+        , _wlColor :: Color
+        , _wlDraw :: Maybe (Wall -> Picture)
+        , _wlSeen :: Bool
+        , _blIDs :: [Int]
+        , _blHP :: Int
+        , _wlIsSeeThrough :: Bool
+        }
+    | Door 
+        { _wlLine :: [Point2] , _wlID :: Int 
+        , _doorMech :: World -> World
+        , _wlColor :: Color
+        , _wlDraw :: Maybe (Wall -> Picture)
+        , _wlSeen :: Bool
+        , _wlIsSeeThrough :: Bool
+        , _doorPathable :: Bool
+        }
+    | Block 
+        { _wlLine :: [Point2]
+        , _wlID :: Int
+        , _wlColor :: Color
+        , _wlDraw :: Maybe (Wall -> Picture)
+        , _wlSeen :: Bool
+        , _blIDs :: [Int]
+        , _blHP :: Int
+        , _wlIsSeeThrough :: Bool
+        , _blVisible :: Bool
+        , _blDegrades :: [Int]
+        , _blShadows :: [Int]
+        }
+
+data ForceField = FF 
+    { _ffLine :: [Point2] , _ffID :: Int 
+    , _ffColor :: Color
+    , _ffDeflect :: Maybe (StdGen -> Point2 -> ForceField -> (Point2,StdGen))
+    , _ffState :: FFState
+    }
+data FFState = FFDestroyable { _ffsHP :: Int }
+
+data SoundOrigin = InventorySound 
+    | BackgroundSound
+    | OnceSound
+    | CrSound Int
+    | CrWeaponSound Int
+    | WallSound Int
+    | CrReloadSound Int
+    | Flamer
+    | ShellSound Int
+    | Flame
+    | LasSound
+    | FootstepSound Int
+    | BlockDegradeSound Int
+    | CrHitSound Int
+    | BarrelHiss Int
+    | GlassBreakSound Int
+  deriving (Eq,Ord,Show)
+
+type Poly = [Point2]
+data PSType = PutCrit Creature
+    | PutLS LightSource Picture
+    | PutButton Button
+    | PutFlIt FloorItem
+    | PutPressPlate PressPlate
+    | PutAutoDoor Point2 Point2
+    | PutBlock [Int] Color [Point2]
+    | PutLineBlock Wall Float Float Point2 Point2
+    | PutTriggerDoor Color (World -> Bool) Point2 Point2
+    | PutBtDoor Color Point2 Float Point2 Point2
+    | PutSwitchDoor Color Point2 Float Point2 Point2
+    | RandPS (State StdGen PSType)
+    | PutNothing
+    | CollectivePS 
+        { _collectiveID  :: Int 
+        , _collectiveNum :: Int 
+        , _collectiveFunction :: [Int] -> State StdGen [PSType]
+        }
+    | LabelPS { _psLabel :: Int, _ps :: PSType}
+    | PutWindow { _pwPoly :: [Point2] , _pwColor :: Color
+                }
+data PlacementSpot = PS
+    { _psPos :: Point2
+    , _psRot :: Float
+    , _psType :: PSType
+    }
+data Room = Room
+    { _rmPolys  :: [Poly]
+    , _rmLinks  :: [(Point2,Float)]
+    , _rmPath :: [(Point2, Point2)]
+    , _rmPS :: [PlacementSpot]
+    , _rmBound :: Poly
+    }
+
+data SubNode a = SN a | InLink | OutLink
+
+data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
+
+makeLenses ''RoomLink
+makeLenses ''World
+makeLenses ''Cloud
+makeLenses ''Creature
+makeLenses ''CreatureState
+makeLenses ''CrSpState
+makeLenses ''Goal
+makeLenses ''LightSource
+makeLenses ''TempLightSource
+makeLenses ''Stance
+makeLenses ''Carriage
+makeLenses ''Posture
+makeLenses ''Item
+makeLenses ''ItemPos
+makeLenses ''ItEffect
+makeLenses ''ItAttachment
+makeLenses ''ItZoom
+makeLenses ''FloorItem
+makeLenses ''Projectile
+makeLenses ''Particle'
+makeLenses ''Wall
+makeLenses ''ForceField
+makeLenses ''FFState
+makeLenses ''PressPlate
+makeLenses ''Button
+makeLenses ''PSType
+makeLenses ''PlacementSpot
+makeLenses ''Room
+
+numColor :: Int -> Color
+numColor 0  = (1,0,0,1) 
+numColor 1  = (0,1,0,1) 
+numColor 2  = (0,0,1,1) 
+numColor 3  = (1,1,0,1)  
+numColor 4  = (0,1,1,1) 
+numColor 5  = (1,0,1,1)  
+numColor 6  = (1,0,0.5,1) 
+numColor 7  = (0.5,0,1,1)  
+numColor 8  = (0,0.5,1,1) 
+numColor 9  = (0,1,0.5,1) 
+numColor 10 = (0.5,1,0,1)
+numColor 11 = (1,0.5,0,1)  
+numColor 12 = (1,1,1,1) 

src/Dodge/Default.hs

@@ -230,6 +230,8 @@ defaultWorld = World
         ]
     , _selLocation = 0
     , _keyConfig = defaultKeyConfigSDL
+    , _varMovementSpeedModifier = 3
+    , _varMovementStrafeSpeedModifier = 3
     }
 youLight = 
 --    LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) 

src/Dodge/Event/Keyboard.hs

@@ -35,6 +35,8 @@ handlePressedKey _    scancode w
     -- Rotation seems to be duplicated here and in Camera.hs ? why
     |  scancode == rotateCameraPlusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w + 0.01}
     |  scancode == rotateCameraMinusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w - 0.01}
+    |  scancode ==   ScancodeF7      = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w - 1}
+    |  scancode ==   ScancodeF8      = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w + 1}
 handlePressedKey _ _ w = Just w
 
 

src/Dodge/Item/Weapon.hs

@@ -331,6 +331,21 @@ launcher = defaultGun
     , _itHammer = NoHammer
     , _itEffect = NoItEffect
     }
+flameLauncher = launcher
+    { _itName = "FLROCKO"
+    , _wpFire = shoot $ aRocket' makeFlameShellAt
+    }
+
+poisonLauncher = launcher 
+    { _itName = "POISROCK"
+    , _wpFire = shoot $ aRocket' makePoisonShellAt
+    }
+
+teslaLauncher = launcher 
+    { _itName = "TESLROCK"
+    , _wpFire = shoot $ aRocket' makeTeslaShellAt
+    }
+
 bezierGun = defaultAutoGun
     { _itName = "B-GUN"
     , _wpFire = maybeSetTarget $ \p ->  shootWithSound 0 
@@ -696,36 +711,80 @@ aTractorBeam col cid w
           dir = _crDir cr
           itRef = _crInvSel cr
 
-aRocket :: Int -> World -> World
-aRocket cid w
+-- |The aRocket' function allows us to define the shell to be used
+aRocket' :: (Int -> Int -> Point2 -> Float -> Projectile) -> Int -> World -> World
+aRocket' shell cid w
         = soundOnce (fromIntegral launcherSound)
-            $ over projectiles (IM.insert i (makeShellAt i cid pos dir)) w
+            $ over projectiles (IM.insert i (shell i cid pos dir)) w
     where i = newProjectileKey w
           cr  = (_creatures w IM.! cid)
           pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
           dir = _crDir cr
 
+aRocket :: Int -> World -> World
+aRocket = aRocket' makeShellAt
+--        = soundOnce (fromIntegral launcherSound)
+--            $ over projectiles (IM.insert i (makeShellAt i cid pos dir)) w
+--    where i = newProjectileKey w
+--          cr  = (_creatures w IM.! cid)
+--          pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
+--          dir = _crDir cr
+
 makeShellAt :: Int -> Int -> Point2 -> Float -> Projectile
-makeShellAt i cid pos dir = Projectile
+makeShellAt i cid pos dir = Shell
     { _ptPos = pos
     , _ptStartPos = pos
     , _ptVel = rotateV dir (1,0)
     , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
     , _ptID = i
     , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
+    , _ptExplosion = shellExplosionAt
+    }
+
+makeFlameShellAt :: Int -> Int -> Point2 -> Float -> Projectile
+makeFlameShellAt i cid pos dir = Shell
+    { _ptPos = pos
+    , _ptStartPos = pos
+    , _ptVel = rotateV dir (1,0)
+    , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
+    , _ptID = i
+    , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
+    , _ptExplosion = makeFlameExplosionAt
+    }
+
+makePoisonShellAt :: Int -> Int -> Point2 -> Float -> Projectile
+makePoisonShellAt i cid pos dir = Shell
+    { _ptPos = pos
+    , _ptStartPos = pos
+    , _ptVel = rotateV dir (1,0)
+    , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
+    , _ptID = i
+    , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
+    , _ptExplosion = makePoisonExplosionAt
+    }
+
+makeTeslaShellAt :: Int -> Int -> Point2 -> Float -> Projectile
+makeTeslaShellAt i cid pos dir = Shell
+    { _ptPos = pos
+    , _ptStartPos = pos
+    , _ptVel = rotateV dir (1,0)
+    , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
+    , _ptID = i
+    , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
+    , _ptExplosion = makeTeslaExplosionAt
     }
 
 moveShell :: Int -> Int -> Int -> Float -> Point2 -> World -> World
 moveShell time i cid rot accel w 
     | time > 40 = if circOnSomeWall oldPos 4 w
-                  then shellExplosionAt oldPos $ over projectiles (IM.delete i) w
+                  then projectileExplosion oldPos $ over projectiles (IM.delete i) w
                   else over (projectiles . ix i . ptPos) (+.+ vel)
                                   $ set (projectiles . ix i . ptPict) piclow
                                   $ set (projectiles . ix i . ptUpdate) 
                                             (moveShell (time-1) i cid rot (rotateV rot accel))
                                     w
     | time == 35 = case thingHit of
-                       Just p  -> shellExplosionAt oldPos
+                       Just p  -> projectileExplosion oldPos
                                     $ over projectiles (IM.delete i) w
                        Nothing -> over (projectiles . ix i . ptPos) (+.+ vel)
                                   $ set (projectiles . ix i . ptPict) pic
@@ -733,7 +792,7 @@ moveShell time i cid rot accel w
                                             (moveShell (time-1) i cid spin accel)
                                     w
     | time >= 20 = case thingHit of
-                       Just p  -> shellExplosionAt oldPos
+                       Just p  -> projectileExplosion oldPos
                                     $ over projectiles (IM.delete i) w
                        Nothing -> over (projectiles . ix i . ptPos) (+.+ vel)
                                   $ set (projectiles . ix i . ptPict) pic
@@ -742,7 +801,7 @@ moveShell time i cid rot accel w
                                     w
     | time > -99 
         = case thingHit of
-                       Just p  -> shellExplosionAt oldPos
+                       Just p  -> projectileExplosion oldPos
                                     $ stopSoundFrom (ShellSound i)
                                     $ over projectiles (IM.delete i) w
                        Nothing -> over (projectiles . ix i . ptPos) (+.+ vel)
@@ -757,7 +816,7 @@ moveShell time i cid rot accel w
                                   $ smokeGen
                                     w
     | time > -200 = case thingHit of
-                       Just p  -> shellExplosionAt oldPos 
+                       Just p  -> projectileExplosion oldPos 
                                     $ stopSoundFrom (ShellSound i)
                                     $ over projectiles (IM.delete i) w
                        Nothing -> over (projectiles . ix i . ptPos) (+.+ vel)
@@ -765,12 +824,13 @@ moveShell time i cid rot accel w
                                   $ set (projectiles . ix i . ptUpdate)
                                             (moveShell (time-1) i cid rot (rotateV rot accel))
                                     w
-    | otherwise = shellExplosionAt oldPos 
+    | otherwise = projectileExplosion oldPos 
                                     $ stopSoundFrom (ShellSound i)
                                     $ over projectiles (IM.delete i) w
         where pt = _projectiles w IM.! i
               oldPos   = _ptPos pt
               vel      = _ptVel pt
+              projectileExplosion = _ptExplosion pt
               newPos   = oldPos +.+ vel
               (frict,g)    = randomR (0.6,0.9) $ _randGen w
               (sparkD,_) = randomR (-0.5,0.5) $ _randGen w
@@ -869,6 +929,74 @@ aFlame a cid w
             resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire)
                                               (shoot $ aFlame angle)
 
+-- The following should be improved....
+makePoisonExplosionAt :: Point2 -> World -> World
+makePoisonExplosionAt p w = soundOnce grenadeBang 
+                        $ makeGasCloud p (velocities!!1)
+                        $ makeGasCloud p (velocities!!2)
+                        $ makeGasCloud p (velocities!!3)
+                        w
+    where 
+          xs = randomRs (-2,2) $ _randGen w  -- one infinite list of randoms
+          velocities = zip (take 10 xs) (drop 10 xs)
+
+makeTeslaExplosionAt :: Point2 -> World -> World
+makeTeslaExplosionAt pos w = soundOnce grenadeBang 
+                        -- This is obviously the best way....
+                        $ over projectiles (IM.insert (pks!!1) (makeTeslaArcAt (pks!!1) pos (xs!!1)))
+                        $ over projectiles (IM.insert (pks!!2) (makeTeslaArcAt (pks!!2) pos (xs!!2)))
+                        $ over projectiles (IM.insert (pks!!3) (makeTeslaArcAt (pks!!3) pos (xs!!3)))
+                        $ over projectiles (IM.insert (pks!!4) (makeTeslaArcAt (pks!!4) pos (xs!!4)))
+                        $ over projectiles (IM.insert (pks!!5) (makeTeslaArcAt (pks!!5) pos (xs!!5)))
+                        $ over projectiles (IM.insert (pks!!6) (makeTeslaArcAt (pks!!6) pos (xs!!6)))
+                        $ over projectiles (IM.insert (pks!!7) (makeTeslaArcAt (pks!!7) pos (xs!!7)))
+                        $ over projectiles (IM.insert (pks!!8) (makeTeslaArcAt (pks!!8) pos (xs!!8)))
+                        $ over projectiles (IM.insert (pks!!9) (makeTeslaArcAt (pks!!9) pos (xs!!9)))
+                        $ over projectiles (IM.insert (pks!!10) (makeTeslaArcAt (pks!!10) pos (xs!!10)))
+                        $ over projectiles (IM.insert (pks!!11) (makeTeslaArcAt (pks!!11) pos (xs!!11)))
+                        $ over projectiles (IM.insert (pks!!12) (makeTeslaArcAt (pks!!12) pos (xs!!12)))
+                        $ over projectiles (IM.insert (pks!!13) (makeTeslaArcAt (pks!!13) pos (xs!!13)))
+                        $ over projectiles (IM.insert (pks!!14) (makeTeslaArcAt (pks!!14) pos (xs!!14)))
+                        $ over projectiles (IM.insert (pks!!15) (makeTeslaArcAt (pks!!15) pos (xs!!15)))
+                        $ over projectiles (IM.insert (pks!!16) (makeTeslaArcAt (pks!!16) pos (xs!!16)))
+                        $ over projectiles (IM.insert (pks!!17) (makeTeslaArcAt (pks!!17) pos (xs!!17)))
+                        $ over projectiles (IM.insert (pks!!18) (makeTeslaArcAt (pks!!18) pos (xs!!18)))
+                        $ over projectiles (IM.insert (pks!!19) (makeTeslaArcAt (pks!!19) pos (xs!!19)))
+                        $ over projectiles (IM.insert (pks!!20) (makeTeslaArcAt (pks!!20) pos (xs!!20)))
+                        $ over projectiles (IM.insert (pks!!21) (makeTeslaArcAt (pks!!21) pos (xs!!21)))
+                        $ over projectiles (IM.insert (pks!!22) (makeTeslaArcAt (pks!!22) pos (xs!!22)))
+                        $ over projectiles (IM.insert (pks!!23) (makeTeslaArcAt (pks!!23) pos (xs!!23)))
+                        $ over projectiles (IM.insert (pks!!24) (makeTeslaArcAt (pks!!24) pos (xs!!24)))
+                        $ over projectiles (IM.insert (pks!!25) (makeTeslaArcAt (pks!!25) pos (xs!!25)))
+                        $ over projectiles (IM.insert (pks!!26) (makeTeslaArcAt (pks!!26) pos (xs!!26)))
+                        $ over projectiles (IM.insert (pks!!27) (makeTeslaArcAt (pks!!27) pos (xs!!27)))
+                        $ over projectiles (IM.insert (pks!!28) (makeTeslaArcAt (pks!!28) pos (xs!!28)))
+                        $ over projectiles (IM.insert (pks!!29) (makeTeslaArcAt (pks!!29) pos (xs!!29)))
+                        w
+    where 
+          -- rad or 360?
+          xs = randomRs (0,7) $ _randGen w
+          p = newProjectileKey w
+          pks = [p..]
+
+makeFlameExplosionAt :: Point2 -> World -> World
+makeFlameExplosionAt p w = soundOnce grenadeBang 
+                        $ makeFlame p (velocities!!1) (Just 0)
+                        $ makeFlame p (velocities!!2) (Just 90)
+                        $ makeFlame p (velocities!!3) (Just 180)
+                        $ makeFlame p (velocities!!4) (Just 0)
+                        $ makeFlame p (velocities!!5) (Just 0)
+                        $ makeFlame p (velocities!!6) (Just 0)
+                        $ makeFlame p (velocities!!7) (Just 0)
+                        $ makeFlame p (velocities!!8) (Just 0)
+                        $ makeFlame p (velocities!!9) (Just 0)
+                        $ makeFlame p (velocities!!0) (Just 0)
+                        $ w
+    where 
+          xs = randomRs (-2,2) $ _randGen w  -- one infinite list of randoms
+          velocities = zip (take 10 xs) (drop 10 xs)
+
+
 makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World
 makeFlame pos vel maycid = over particles' ((:) theFlame)
     where theFlame = 
@@ -960,10 +1088,13 @@ reflect a b = a + 2*(a-b)
 
 moveGrenade :: Int -> Float -> Int -> World -> World
 moveGrenade 0 dir pID w = over projectiles (IM.delete pID) 
-                            $ makeExplosionAt (_ptPos (_projectiles w IM.! pID)) 
+                            $ explosion (_ptPos (_projectiles w IM.! pID)) 
                             -- $ set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict) 
                             --      (drawWeapon $ grenadePic 50)
                             w
+                        where
+                            pt = _projectiles w IM.! pID
+                            explosion = _ptExplosion pt
 moveGrenade time dir pID w 
     = case hitWl of
         Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld
@@ -1242,6 +1373,25 @@ grenade = Throwable
     }
     where fuseTime = 50
           f x = 50 / fromIntegral x
+
+
+flameGrenade :: Item
+flameGrenade = grenade {
+     _itName = "FLMGREN " ++ show fuseTime
+     , _twFire = throwGrenade' makeFlameExplosionAt fuseTime
+    }
+    where fuseTime = 50
+          f x = 50 / fromIntegral x
+
+teslaGrenade :: Item
+teslaGrenade = grenade {
+     _itName = "TLSGREN " ++ show fuseTime
+     , _twFire = throwGrenade' makeTeslaExplosionAt fuseTime
+    }
+    where fuseTime = 50
+          f x = 50 / fromIntegral x
+
+
 increaseFuse :: Int -> Int -> World -> World
 increaseFuse fuse i w = w & creatures . ix 0 . crInv . ix itRef . itScrollUp .~ decreaseFuse newTime
                           & creatures . ix 0 . crInv . ix itRef . itScrollDown .~ increaseFuse newTime
@@ -1281,15 +1431,16 @@ remoteBomb = defaultThrowable
     }
 
 
-throwGrenade :: Int -> Int -> World -> World
-throwGrenade fuseTime n w = setWp $ removePict $ over projectiles addG $ set randGen g w
+throwGrenade' :: (Point2 -> World -> World) -> Int -> Int -> World -> World
+throwGrenade' explosion fuseTime n w = setWp $ removePict $ over projectiles addG $ set randGen g w
     where addG = IM.insert i
-                   $ Projectile { _ptPos = p
+                   $ Shell { _ptPos = p
                               , _ptStartPos = p
                               , _ptVel = v
                               , _ptPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0
                               , _ptID = i
                               , _ptUpdate = moveGrenade fuseTime dir i
+                              , _ptExplosion = explosion
                               }
           j = _crInvSel $ _creatures w IM.! n
           removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank
@@ -1308,6 +1459,35 @@ throwGrenade fuseTime n w = setWp $ removePict $ over projectiles addG $ set ran
           setWp :: World -> World
           setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20
 
+throwGrenade :: Int -> Int -> World -> World
+throwGrenade = throwGrenade' makeExplosionAt
+--    setWp $ removePict $ over projectiles addG $ set randGen g w
+--    where addG = IM.insert i
+--                   $ Shell { _ptPos = p
+--                              , _ptStartPos = p
+--                              , _ptVel = v
+--                              , _ptPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0
+--                              , _ptID = i
+--                              , _ptUpdate = moveGrenade fuseTime dir i
+--                              , _ptExplosion = makeExplosionAt
+--                              }
+--          j = _crInvSel $ _creatures w IM.! n
+--          removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank
+--          i = newProjectileKey w
+--          (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w)
+--          (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g
+--         -- v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w)
+--          v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w)
+--          v | magV v' > 6 = 6 *.* normalizeV v'
+--            | otherwise   = v'
+--          cr = _creatures w IM.! n
+--          p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
+--          p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
+--            | otherwise             = p'
+--          dir = argV v 
+--          setWp :: World -> World
+--          setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20
+
 throwArmReset :: Int -> ItEffect
 throwArmReset x =
     ItInvEffect {_itInvEffect = f
@@ -2058,3 +2238,7 @@ makeLaserScope p ep d relFrac = Particle'
                                 ]
     ,_ptUpdate' = \w pt -> (w, Just $ pt & ptUpdate' .~ \w' _ -> (w',Nothing))
     }
+
+
+
+