Add source files, commit before reverting pictures to lists

app/Main.hs

@@ -6,9 +6,6 @@ import Shaders
 import Render
 import Shapes
 
-import Dodge.Rendering
-import Dodge.RenderPicture
-import Dodge.Picture
 import Dodge.Prototypes
 import Dodge.Data
 import Dodge.Initialisation
@@ -17,7 +14,11 @@ import Dodge.Layout
 import Dodge.LoadSound
 import Dodge.Update
 import Dodge.KeyEvents
-import Dodge.Preload
+import Dodge.Rendering
+
+import Picture
+import Picture.Render
+import Picture.Preload
 
 import Control.Concurrent
 import Control.Lens
@@ -38,31 +39,6 @@ initWorld = initialWorld
 pps = [(0,0),(50,0),(0,25)]
 ppt = [(0,0),(-50,0),(20,25)]
 
-tSh = TextShape 
-        [((0.0,0.0,0),(1,0,1,1),(s,1))
-        ,((0.5,0.0,0),(1,1,1,1),(e,1))
-        ,((0.5,1.0,0),(1,1,1,1),(e,0))
-        ,((0.0,1.0,0),(1,1,1,1),(s,0))
-        ]
-    where x = 1/128
-          s = 20 * x
-          e = s + x
-tSh' = TShape' 
-        [0.0,0.0,0,1,0,1,1,s,1
-        ,0.5,0.0,0,1,1,1,1,e,1
-        ,0.5,1.0,0,1,1,1,1,e,0
-        ,0.0,1.0,0,1,1,1,1,s,0
-        ] TriangleFan
-    where x = 1/128
-          s = 20 * x
-          e = s + x
-tSha = TShape' 
-    [0.0,0.0,0,1,1,1,1
-    ,50 ,0.0,0,1,1,1,1
-    ,50 ,50 ,0,1,1,1,1
-    ,0.0,1.0,0,1,1,1,1
-    ] TriangleFan
-
 main :: IO ()
 main = do
 --    loadedSounds <- loadSounds
@@ -70,15 +46,17 @@ main = do
         "windowName"
         800 600
         doPreload'
+        cleanUpPreload
         (initializeWorld $ generateFromTree lev1 $ initWorld)
         (-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade
          \preData w -> --do render setparams w egFade
-                      --renderPicture preData (draw blank w)
+                      renderPicture' preData (draw blank w)
-                      renderPicture' preData (pictures' [--scale' 0.5 0.9 $ polygon' [(0,0),(0,0.5),(0.5,0.5),(0.5,0.0)]
+--            renderPicture' preData 
-                                                       scale' 0.0005 0.0005 $ text' "asdf"
+--                          (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
-                                                       ]
+--                                    ,scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
-                                             )
+--                                    ,color red $ scale 0.0005 0.0005 $ text "asdf"
-          --              renderTex'' preData tSh
+--                                    ]
+--                          )
         )
         handleEvent
         (\w -> Just $ update w)

package.yaml

@@ -38,6 +38,8 @@ dependencies:
 - monad-loops
 - JuicyPixels
 - vector
+- dlist
+- deepseq
 
 library:
   source-dirs: src
@@ -48,8 +50,15 @@ executables:
     source-dirs:         app
     ghc-options:
     - -threaded
+    - -O2
     - -rtsopts
     - -with-rtsopts=-N
+    - -fno-liberate-case 
+    - -fno-state-hack
+    - -funfolding-use-threshold1000 
+    - -funfolding-keeness-factor1000 
+    - -fllvm 
+    - -optlo-O3
     dependencies:
     - loop
 

src/Dodge/Base.hs

@@ -0,0 +1,740 @@
+--{-# LANGUAGE Strict #-}
+{-# LANGUAGE BangPatterns #-}
+module Dodge.Base where
+-- imports {{{
+import Dodge.Data
+
+import Geometry
+import Picture
+
+import Control.Lens
+import Control.Monad.State
+
+import Data.List
+import Data.Function
+import Data.Maybe
+import Data.Bifunctor
+
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
+import qualified Data.Set as S
+
+-- }}}
+--
+you :: World -> Creature
+you w = _creatures w IM.! _yourID w
+
+aCrPos :: Int -> World -> Point2
+aCrPos i w = _crPos $ _creatures w IM.! i
+
+yourItem :: World -> Item
+yourItem w = _crInv (you w) IM.! _crInvSel (you w)
+
+yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
+
+halfWidth,halfHeight :: World -> Float
+halfWidth w = _windowX w / 2
+halfHeight w = _windowY w / 2
+
+hasLOS :: Point2 -> Point2 -> World -> Bool
+{-# INLINE hasLOS #-}
+hasLOS p1 p2 w = (not $ collidePointWallsSimple p1 p2 nearbyWalls) 
+                    && (not $ collidePointSmoke p1 p2 nearbySmoke)
+    where nearbyWalls = wallsAlongLine p1 p2 w
+          nearbySmoke = _smoke w -- smokeAlongLine p1 p2 w
+
+smokeLOS :: Point2 -> Point2 -> World -> Bool
+smokeLOS p1 p2 w = not $ collidePointSmoke p1 p2 nearbySmoke
+    where nearbySmoke = _smoke w
+
+hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
+hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w
+                         of Just _ -> False
+                            Nothing -> True && smokeLOS p1 p2 w
+
+isWalkable :: Point2 -> Point2 -> World -> Bool
+isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls
+    where nearbyWalls = wallsAlongLine p1 p2 w
+
+canSee :: Int -> Int -> World -> Bool
+canSee i j w = hasLOS p1 p2 w
+--canSee i j w = not $ collidePointWallsSimple p1 p2
+--                                      nearbyWalls
+    where p1 = _crPos (_creatures w IM.! i)
+          p2 = _crPos (_creatures w IM.! j)
+          nearbyWalls = wallsAlongLine p1 p2 w
+
+canSeePoint :: Int -> Point2 -> World -> Bool
+canSeePoint i p w = hasLOS p1 p w
+--canSeePoint i p w = case collidePointWalls p1 p nearbyWalls
+--                    of Just _ -> False
+--                       Nothing -> True
+    where nearbyWalls = wallsAlongLine p1 p w
+          p1 = _crPos (_creatures w IM.! i)
+
+
+pathToPointFireable :: Int -> Point2 -> World -> Bool
+pathToPointFireable i p w = not $ collidePointWallsSimple (_crPos (_creatures w IM.! i))
+                                                          p
+                                                          walls
+    where walls = IM.filter (not . isJust . \wl -> wl ^? blHP) 
+                    $ wallsAlongLine p1 p w
+          p1 = _crPos (_creatures w IM.! i)
+
+canSeePointAll :: Int -> Point2 -> World -> Bool
+canSeePointAll i targPos w = and $ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p)))
+                                  [(1,0),(0,1),(-1,0),(0,-1)]
+    where cr = _creatures w IM.! i
+          cpos = _crPos cr
+          radius = _crRad cr
+
+canSeeAny :: Int -> Int -> World -> Bool
+canSeeAny fromID toID w = or $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p)))
+                                  [(1,0),(0,1),(-1,0),(0,-1)]
+    where cr = _creatures w IM.! toID
+          cpos = _crPos cr
+          radius = _crRad cr
+
+canSeeAll :: Int -> Int -> World -> Bool
+canSeeAll fromID toID w = and $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p)))
+                                  [(1,0),(0,1),(-1,0),(0,-1)]
+    where cr = _creatures w IM.! toID
+          cpos = _crPos cr
+          radius = _crRad cr
+
+canWalk :: Int -> Int -> World -> Bool
+canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
+    where ipos = _crPos (_creatures w IM.! i)
+          jpos = _crPos (_creatures w IM.! j)
+
+canSeeIndirect :: Int -> Int -> World -> Bool
+canSeeIndirect i j w = case collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
+                         of Just _ -> False
+                            Nothing -> True && smokeLOS ipos jpos w
+    where ipos = _crPos (_creatures w IM.! i)
+          jpos = _crPos (_creatures w IM.! j)
+    
+canSeeFire :: Point2 -> Point2 -> World -> Bool
+canSeeFire p p' w = (not $ collidePointFireVision p p' $ wallsAlongLine p p' w)
+                    && smokeLOS p p' w
+
+canSeeFireVision :: Int -> Int -> World -> Bool
+canSeeFireVision i j w = (not $ collidePointFireVision ipos jpos $ wallsAlongLine ipos jpos w)
+                            && smokeLOS ipos jpos w
+    where ipos = _crPos (_creatures w IM.! i)
+          jpos = _crPos (_creatures w IM.! j)
+
+canSeeFireVisionAny :: Int -> Int -> World -> Bool
+canSeeFireVisionAny i j w = (not $ and $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
+                                 $ zipWith collidePointFireVision ips jps
+                            ) && smokeLOS (_crPos icr) (_crPos jcr) w
+    where icr = _creatures w IM.! i
+          jcr = _creatures w IM.! j
+          ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+          jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+
+
+canSeeFireVisionAll :: Int -> Int -> World -> Bool
+canSeeFireVisionAll i j w = (not $ or $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
+                                 $ zipWith collidePointFireVision ips jps
+                            ) && smokeLOS (_crPos icr) (_crPos jcr) w
+    where icr = _creatures w IM.! i
+          jcr = _creatures w IM.! j
+          ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+          jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+
+-- looks for first collision of a point with walls
+-- if found, returns wall
+-- I'm sure there is a better way of doing this, one that propagates Nothing in a nice way
+
+--wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
+--wallsOnLine p1 p2 ws = hitWalls
+--    where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+--          hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
+
+wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
+wallsOnLine p1 p2 ws = hitWalls
+    where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+          hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
+
+wallOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Wall
+wallOnLine p1 p2 ws 
+    = listToMaybe $ sortBy f hitWalls
+    where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+    --where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+          hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
+          f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2)))
+
+wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall]
+wallsOnCirc p r wls = IM.elems $ IM.filter f wls
+    where f wl = circOnLine (_wlLine wl !! 0) (_wlLine wl !! 1) p r
+
+wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
+wallsNearPoint p w =  IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where (x,y) = zoneOfPoint p
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+-- possible BUG, was associated with thingsHitLongLine
+wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
+{-# INLINE wallsAlongLine #-}
+--wallsAlongLine a b w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfLine a b]
+--    where f i m = case IM.lookup i m of Just val -> val
+--                                        _        -> IM.empty
+wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
+    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+          kps = zoneOfLine' a b
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
+{-# INLINE wallsNearZone' #-}
+wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
+    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+
+wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
+wallsAlongCirc p r w =  IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
+    where f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+allWalls :: World -> IM.IntMap Wall
+allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w
+
+creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
+creaturesNearPoint p w =  IM.unions [f b $ f a $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where (x,y) = zoneOfPoint p
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+cloudsNearPoint :: Point2 -> World -> IM.IntMap Cloud
+cloudsNearPoint p w =  IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where (x,y) = zoneOfPoint p
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+-- possible BUG, occurs when used in thingsHitLongLine
+creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
+--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]
+--    where f i m = case IM.lookup i m of Just val -> val
+--                                        _        -> IM.empty
+creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps
+    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _creaturesZone w) s))
+          kps = zoneOfLine' a b
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+zoneSize :: Float
+zoneSize = 50
+--zoneSize = 100
+          
+floorHun :: Float -> Int
+floorHun x = floor $ x / zoneSize
+zoneOfPoint :: Point2 -> (Int,Int)
+zoneOfPoint (x,y) = (floorHun x, floorHun y)
+
+zoneNearPoint :: Point2 -> [(Int,Int)]
+zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where x = floorHun x'
+          y = floorHun y'
+
+zoneAroundPoint :: Point2 -> [(Int,Int)]
+zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
+    where x = floorHun x'
+          y = floorHun y'
+
+zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
+zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs
+    where x = floorHun x'
+          y = floorHun y'
+          xs = IS.fromAscList [x-i..x+i]
+          ys = IS.fromAscList [y-i..y+i]
+
+-- the laser seemed to be occasionally missing creatures,
+-- if this reoccurs, maybe change
+-- divide line factor from 2 to 1.5
+bres :: Point2 -> Point2 -> [(Int,Int)]
+bres a b = bresenham (zoneOfPoint a) (zoneOfPoint b)
+
+bresx :: Point2 -> Point2 -> [(Int,Int)]
+bresx a b = bresenham (x-1,y-1) (x'-1,y'-1)
+    where (x,y) = zoneOfPoint a
+          (x',y') = zoneOfPoint b
+
+zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
+zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
+                                 $ bresenham (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
+    where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
+--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
+--                                 $ bresenham (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n))
+--    where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]]
+--          n = zoneSize * 0.5
+
+expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
+{-# INLINE expandLine #-}
+expandLine xs = IM.map expandSet
+                  $ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
+    where im = IM.fromListWith IS.union $ map (\(a,b)->(a,IS.singleton b)) xs
+          expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
+          --expandSet s = s
+                where mk = IS.findMax s
+
+zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
+{-# INLINE zoneOfLine' #-}
+zoneOfLine' a b = expandLine $ bresenham (x-1,y-1) (x'-1,y'-1)
+    where (x,y) = zoneOfPoint a
+          (x',y') = zoneOfPoint b
+                        
+--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
+--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
+
+zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
+zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
+
+-- looking at this again, I am not convinced it deals correctly with the
+-- rotation of the world
+zoneOfScreen :: World -> [(Int,Int)]
+zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
+                        , b <- [y - n .. y + n]
+                 ]
+    where (x,y) = zoneOfPoint $ _cameraPos w
+          n = ceiling $ wh / (_cameraZoom w * zoneSize)
+          wh = max (_windowX w) (_windowY w)
+
+zoneOfDoubleScreen :: World -> [(Int,Int)]
+zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
+                        , b <- [y - n .. y + n]
+                 ]
+    where (x,y) = zoneOfPoint $ _cameraPos w
+          n = (ceiling $ wh / (_cameraZoom w * zoneSize)) * 2
+          wh = max (_windowX w) (_windowY w)
+
+zoneOfSight :: World -> [(Int,Int)]
+zoneOfSight w = [(a,b) | a <- [minimum xs .. maximum xs]
+                       , b <- [minimum ys .. maximum ys]
+                ]
+    where (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraCenter w]
+
+screenPolygon :: World -> [Point2]
+screenPolygon w = [tr,tl,bl,br]
+    where scRot  = rotateV (_cameraRot w)
+          scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
+          scTran p = p +.+ _cameraPos w
+          tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w) 
+          tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w) 
+          br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
+          bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
+
+wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
+wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
+    where f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
+ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y
+
+ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
+ixNZ z p = lookLookups (zoneNearPoint p) z
+
+lookLookup :: Int -> Int -> (IM.IntMap (IM.IntMap a)) -> Maybe a
+lookLookup i j z = case IM.lookup i z of
+                        Just z' -> IM.lookup j z'
+                        Nothing -> Nothing
+
+lookLookups :: [(Int,Int)] -> (IM.IntMap (IM.IntMap a)) -> [a]
+lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
+
+-- looks for first collision of a point with walls
+-- if found, gives point and reflection velocity
+collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collidePointWalls p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe 
+                                        (( \(x:y:_) -> fmap (flip (,)
+                                                             (reflectIn (x -.- y) (p2 -.- p1))
+                                                            . (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
+                                                            ) (intersectSegSeg' p1 p2 x y)
+                                         ) . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+-- looks for if a point collides with walls
+collidePointWallsSimple :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointWallsSimple p1 p2 = any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                        . _wlLine
+
+collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointWalkable p1 p2 ws = any (isJust 
+                                    . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                    . _wlLine
+                                    ) unwalkableWalls
+    where unwalkableWalls = IM.filter notDoor ws
+          notDoor (AutoDoor {}) = False
+          notDoor _         = True
+
+furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
+furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems 
+                                    $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                                    . _wlLine
+                                                  ) ws
+                                        ) ++ [p2]
+
+collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
+collidePointIndirect p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems 
+                                    $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                                    . _wlLine
+                                                  ) notWindows
+    where notWindows = IM.filter (not . _wlIsSeeThrough) ws
+
+collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
+collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems 
+                                    $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                                    . _wlLine
+                                                  ) notWindows
+    where notWindows = IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))
+                                 ) ws
+
+collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointFireVision p1 p2 ws =  any ( isJust
+                                       . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                       . _wlLine
+                                       ) 
+                                       $ IM.filter notBlockWindow ws
+    where notBlockWindow wl = case wl ^? blHP of
+                                Just _  -> not $ _wlIsSeeThrough wl
+                                Nothing -> True
+
+collidePointSmoke :: Point2 -> Point2 -> [Smoke] -> Bool
+collidePointSmoke a b = any $ isJust . uncurry (intersectSegSeg' a b) . smokePerpLine a b
+
+smokePerpLine :: Point2 -> Point2 -> Smoke -> (Point2,Point2)
+smokePerpLine a b sm = (p +.+ orth, p -.- orth)
+    where
+        p = _smPos sm
+        orth = _smRad sm *.* safeNormalizeV (vNormal (a -.- b))
+
+-- shit this is ugly
+lineOfThickness :: Float -> [Point2] -> Picture
+lineOfThickness t = pictures . f
+    where f (x:y:ys) 
+            | x == y = f (x:ys)
+            | otherwise 
+                     = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
+          f _        = []
+          n a b      = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
+
+wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
+wedgeOfThickness t x y 
+    | x == y    = blank
+    | otherwise = pictures [uncurry translate x $ circleSolid (0.5*t)
+                           ,polygon [x +.+ n x y, x -.- n x y, y]
+                           ]
+    where n a b      = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
+
+insertInZoneWith :: Int -> Int -> (a -> a -> a) -> a -> IM.IntMap (IM.IntMap a) 
+                                            -> IM.IntMap (IM.IntMap a)
+insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj
+    where-- f :: IM.IntMap a -> IM.IntMap a -> IM.IntMap a
+          f _ = IM.insertWith fun y obj
+
+insertIMInZone :: Int -> Int -> Int -> a -> IM.IntMap (IM.IntMap (IM.IntMap a)) 
+                                            -> IM.IntMap (IM.IntMap (IM.IntMap a))
+insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton obid obj
+    where f _ = IM.insertWith g y $ IM.singleton obid obj
+          g _ = IM.insert obid obj
+
+adjustIMZone :: (a -> a) -> Int -> Int -> Int -> IM.IntMap (IM.IntMap (IM.IntMap a)) 
+                                              -> IM.IntMap (IM.IntMap (IM.IntMap a))
+adjustIMZone f x y n m = IM.adjust f' x m
+    where f'  = IM.adjust f'' y
+          f'' = IM.adjust f n
+
+
+newKey :: IM.IntMap a -> Int
+newKey m = case IM.lookupMax m of
+                        Just (n,_)  -> n+1
+                        Nothing     -> 0
+
+newParticleKey :: World -> Int
+newParticleKey w = case IM.lookupMax (_particles w) of
+                        Just (n,_)  -> n+1
+                        Nothing     -> 0
+newCrKey :: World -> Int
+newCrKey w = case IM.lookupMax (_creatures w) of
+                        Just (n,_)  -> n+1
+                        Nothing     -> 0
+
+insertNewKey :: a -> IM.IntMap a -> IM.IntMap a
+insertNewKey x m = case IM.lookupMax m of
+                        Nothing -> IM.singleton 0 x
+                        Just (k,_) -> IM.insert (k+1) x m
+
+reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
+reflectPointCreature p1 p2 cr = 
+    case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
+        Nothing -> Nothing
+        Just p3 -> Just ( p1
+                        , errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) 
+                            +.+ (_crPos cr -.- _crOldPos cr)
+                        --, errorNormalizeV 36 $ 
+                        --  ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
+                        --     -.- _crOldPos cr
+                        , _crID cr)
+
+reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
+reflectPointCreatures p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
+                                                (reflectPointCreature p1 p2) cs
+    where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
+
+
+reflectCircCreature :: Float -> Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
+reflectCircCreature rad p1 p2 cr = 
+    case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of
+        Nothing -> Nothing
+        Just p3 -> Just ( p1
+                        , errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) 
+                            +.+ (_crPos cr -.- _crOldPos cr)
+                        --, errorNormalizeV 38 $ 
+                        --  ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
+                        --     -.- _crOldPos cr
+                        , _crID cr)
+
+reflectCircCreatures :: Float -> Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
+reflectCircCreatures rad p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
+                                                (reflectCircCreature rad p1 p2) cs
+    where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
+
+-- collides a point with forcefields
+-- if found, returns point of collision, deflection if required, and the id
+collidePointFFs = undefined
+collidePointFF  = undefined
+--
+--collidePointFFs :: Point2 -> Point2 -> StdGen -> IM.IntMap ForceField 
+--                    -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
+--collidePointFFs p1 p2 g fs = listToMaybe $ sortBy f $ IM.elems 
+--                            $ IM.mapMaybe (collidePointFF p1 p2 g) fs
+--    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+--
+--collidePointFF :: Point2 -> Point2 -> StdGen -> ForceField 
+--                    -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
+--collidePointFF p1 p2 g ff = fmap f ip
+--    where (p3:p4:_) = _ffLine ff
+--          ip  = intersectSegSeg' p1 p2 p3 p4
+--          ref = (_ffDeflect ff) <*> Just g <*> Just (p2 -.- p1) <*> Just ff
+--          f p = (p, (ref, _ffID ff))
+--
+
+-- looks for first collision of a point with walls
+-- if found, gives point and reflection velocity, reflection damped in normal
+collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collidePointWalls' p1 p2 ws 
+    = listToMaybe $ sortBy f $ IM.elems 
+        $ IM.mapMaybe 
+            (( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1)) 
+                                . (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
+                                ) 
+                                (intersectSegSeg' p1 p2 x y)
+                                         ) . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+
+-- 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' p1 p2 rad ws 
+    = listToMaybe $ sortBy f $ IM.elems 
+        $ IM.mapMaybe 
+            (( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1)) 
+                                . (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
+                                ) 
+                                (intersectSegSeg' p1 p2 x y)
+                                         ) . shiftByRad . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+          shiftByRad (a:b:_) = map ((+.+) (rad *.* normalizeV (vNormal (a -.- b))))
+                                   [a +.+ rad *.* (normalizeV (a -.-b))
+                                   ,b +.+ rad *.* (normalizeV (b -.-a))
+                                   ]
+-- this shifts the wall out, and for outer corners extends the wall
+-- not sure what this does for inner corners, hopefully won't cause a problem
+-- the alternative would be to separately bounce off corner points...
+-- unfortunately, doesn't allow for collisions when the circle spawns on the
+-- wall
+
+-- looks for first collision of a point with walls
+-- if found, gives point and normal of wall
+collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe 
+                                        (( \(x:y:_) -> fmap (flip (,) ( vNormal $ x -.- y )) 
+                                                            (intersectSegSeg' p1 p2 x y)
+                                         ) . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+
+-- looks for first collision of a point with walls
+-- if found, gives point and colour of wall
+collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color)
+collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe 
+                                        ( (\(m, c) -> fmap (flip (,) c) m)
+                                        . (\w -> (intersectSegSeg' p1 p2 
+                                                    (_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+-- looks for first collision of a point with walls
+-- if found, gives point, and normal and colour of wall
+collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
+collidePointWallsNormCol p1 p2 ws 
+    = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws
+    where f (a,_,_) (b,_,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+          ls w = let (x:y:_) = _wlLine w
+                 in  (intersectSegSeg' p1 p2 x y, vNormal (x -.- y), _wlColor w)
+          m w = let (a1,a2,a3) = ls w
+                in  fmap (\a4 -> (a4,a2,a3)) a1
+
+--returns the first creature, if any, that a point intersects with
+collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
+collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc' p1 p2 (_crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csnd (_,a) (_,b) = compare a b
+--as for collidePointCreatures, only increases the radius of creatures by a
+--fixed amount, thus collides a moving circle with creaures
+collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
+collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc' p1 p2 (rad + _crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csnd (_,a) (_,b) = compare a b
+
+
+--returns the first creature, if any, that a point intersects with, gives point
+--in creature on line
+collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int)
+collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+          f (cID,(p,_)) = (p,cID)
+collideCircCrsPoint :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int)
+collideCircCrsPoint p1 p2 rad w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+          f (cID,(p,_)) = (p,cID)
+
+
+-- makes a creatures not hittable
+collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
+collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
+                                       ) 
+                                       (IM.delete cid $ _creatures w)
+    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+          f (cID,(p,_)) = (p,cID)
+
+circOnSomeWall :: Point2 -> Float -> World -> Bool
+circOnSomeWall p rad w = any (\(x:y:_) -> circOnLine x y p rad) 
+                            $ fmap _wlLine $ IM.elems $ wallsNearPoint p w
+
+crsNearLine :: Float -> [Point2] -> World -> Bool
+crsNearLine d (p1:p2:_) w = any (\c -> circOnLine p1 p2 (_crPos c) (d + _crRad c)) 
+                                $ IM.filter (\cr -> _crMass cr > 4) $ _creatures w
+
+crsNearPoint :: Float -> Point2 -> World -> Bool
+crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w)
+
+crsOnLine :: Point2 -> Point2 -> World -> [Creature]
+crsOnLine p1 p2 w = IM.elems 
+                        $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr))
+                        $ _creatures w
+
+crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
+crsOnThickLine thickness p1 p2 w = IM.elems 
+                        $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr + thickness))
+                        $ _creatures w
+
+nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
+nearestCrInRad p r w = let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
+                           sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
+                       in  listToMaybe sortedCrs
+
+nearestCrInTri :: Point2 -> Float -> Float -> World -> Maybe Creature
+nearestCrInTri p dir x w 
+    = let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
+          sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
+      in  listToMaybe sortedCrs
+        where tri = [p 
+                    ,p +.+ rotateV (dir-pi/4) (x,0)
+                    ,p +.+ rotateV (dir+pi/4) (x,0)
+                    ]
+
+nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature
+nearestCrInFront p dir x w 
+    = let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
+          sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
+      in  listToMaybe sortedCrs
+        where rec = [p
+                    ,pR
+                    ,pR1
+                    ,pL1
+                    ,pL
+                    ]
+              pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
+              pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
+              pR1 = pR +.+ rotateV dir (x/2,0)
+              pL1 = pL +.+ rotateV dir (x/2,0)
+
+crInPolygon :: Creature -> [Point2] -> Bool
+crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
+
+onLayer :: Layer -> Picture -> Picture
+onLayer l = setDepth (fromIntegral (levLayer l) / 100)
+
+--onLayer :: Layer -> Picture -> [(Picture, [Int])]
+--onLayer l p = [(p, [levLayer l])]
+
+onLayerL :: [Int] -> Picture -> Picture
+onLayerL is = setDepth (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..])
+
+levLayer :: Layer -> Int
+levLayer BgLayer            = 20
+levLayer PressPlateLayer    = 45
+levLayer CorpseLayer        = 50
+levLayer FlItLayer          = 55
+levLayer CrLayer            = 60
+levLayer WlLayer            = 65
+levLayer GloomLayer         = 67
+levLayer UPtLayer           = 70
+levLayer PtLayer            = 72
+levLayer HPtLayer           = 73
+levLayer ShadowLayer        = 75   
+levLayer LabelLayer         = 80
+levLayer InvLayer           = 85
+levLayer MenuLayer          = 90
+
+mouseWorldPos :: World -> Point2
+mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
+
+logistic :: Float -> Float -> Float -> (Float -> Float)
+logistic x0 l k x = l / (1 + exp (k*(x0 - x)))
+
+wallLOS :: [Point2] -> Point2 -> Point2 -> Bool
+{-# INLINE wallLOS #-}
+wallLOS !(x:y:_) !c !p = isRHS c x y || isLHS p x' y' || isLHS c p x || isRHS c p y
+    where n = 10 *.* (normV . vNormal $ y -.- x)
+          x' = x +.+ n
+          y' = y +.+ n
+
+wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool
+{-# INLINE wallsLOS #-}
+wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls
+
+translateDrawing = translate
+rotateDrawing = rotate

src/Dodge/Block.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE BangPatterns #-}
+module Dodge.Block where
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+
+import Geometry
+import Picture.Data
+
+import Control.Lens
+
+import Data.List
+
+import Data.Function
+import qualified Data.IntMap.Strict as IM
+import System.Random
+import Control.Monad.State
+
+updateBlocks :: World -> World
+updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes 
+                    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls)
+                 degradeBlocks 
+--                    w                
+   where  degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
+          removeFromZone :: Wall -> World -> World
+          removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
+            where (x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1)
+          deadPanes = filter blockIsDead (IM.elems $ _walls w)
+          deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
+          blockIsDead wl = case wl ^? blHP of Just x  -> x <= 0
+                                              Nothing -> False
+
+
+killBlock :: Wall -> World -> World
+killBlock bl w =  f bl .
+                  flip (foldr unshadow)
+--                  flip (foldr (\i -> set (walls . ix i . blVisible) (True)))
+                         (_blShadows bl)
+                        $ w
+    where
+        f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
+        f bl          = hitSound' bl
+        hitSound bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+8) 25 0 
+                    | otherwise = soundMultiFrom sos soundid 25 0 
+        hitSound' bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+4) 25 0 
+                     | otherwise = soundMultiFrom sos soundid 25 0 
+        sos = [BlockDegradeSound 0,BlockDegradeSound 1]
+        (soundid,_) = randomR (29,32) $ _randGen w
+        unshadow :: Int -> World -> World
+        unshadow bid w = case w ^? walls . ix bid of 
+                            Just b  -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
+                                       in  w & wallsZone . ix x . ix y . ix bid . blVisible %~ \_ -> True
+                            Nothing -> w
+
+degradeBlock :: Wall -> World -> World
+degradeBlock bl w = let blid = _wlID bl
+                        bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
+                        ps = reverse $ orderPolygon $ nub $ concatMap _wlLine bls
+                        (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
+                        (x:xs) = _blDegrades bl
+                    in  addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
+
+pushPointTowardsBy :: RandomGen g => Float -> Point2 -> [Point2] -> State g Point2
+pushPointTowardsBy x p ps = do
+    xs <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps))
+    let toAdd p' y = y *.* (p' -.- p)
+    return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
+
+shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2]
+shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps
+
+
+addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
+addBlock (p:ps) hp col isSeeThrough degradability w 
+    | hp <= 0 && degradability == [] = w
+    | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
+    | otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
+      $ over walls (IM.union blocks) w
+--addBlock (p:p':ps) w = over walls (IM.insert i b) w
+    where 
+        lines = zip (p:ps) (ps ++ [p])
+        i = newKey $ _walls w
+        is = [i.. i + length lines-1]
+        blocks = IM.fromList $ zip is 
+                  $ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
+                                               , _wlID = j
+                                            --   , _wlColor = greyN 0.5
+                                               , _wlColor = col
+                                               , _wlDraw = Nothing
+                                               , _wlSeen = False
+                                               , _blIDs = is
+                                               , _blHP = hp
+                                               , _wlIsSeeThrough = isSeeThrough
+                                               , _blVisible = True
+                                               , _blShadows = []
+                                               , _blDegrades = degradability
+                                               }
+                             ) is lines
+        wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
+                          = insertIMInZone x y wlid wl
+                      | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
+          where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
+                wlid  = _wlID wl
+                ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
+        

src/Dodge/Camera.hs

@@ -0,0 +1,163 @@
+module Dodge.Camera where
+
+import Dodge.Data
+import Dodge.Base
+
+import Geometry
+
+import Control.Lens
+import Control.Monad
+
+import Data.Maybe
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+
+import qualified SDL as SDL
+
+updateCamera :: World -> World
+updateCamera = rotCam . moveCamera . updateAimTime . updateScopeZoom
+
+updateAimTime :: World -> World
+updateAimTime w 
+    | SDL.ButtonRight `S.member` _mouseButtons w 
+                = w & cameraAimTime %~ \t -> min (t+1) 10
+    | otherwise = w & cameraAimTime %~ \t -> max (t-1)  0
+
+moveCamera :: World -> World
+moveCamera w = w & cameraPos .~ idealPos
+                 & cameraCenter .~ sightFrom
+    where aimRangeFactor | _cameraZoom w == 0 = 0
+                         | otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w
+          aimTimeFactor = fromIntegral (w ^. cameraAimTime) / 10 
+          aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1
+                     | otherwise                                  = 0
+          ypos = _crPos $ you w
+          idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
+          currentOffset = currentPos -.- camCenter
+          idealPos = camCenter +.+ rotateV (_cameraRot w) 
+                                           -- (aimRangeFactor * aimTimeFactor *.* _mousePos w)
+                                            (aimRangeFactor * aimingMult *.* _mousePos w)
+          currentPos = _cameraPos w
+          camCenter  = ypos +.+ scope
+          isCam :: Bool
+          isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera
+          scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos
+          sightFrom | isCam     = camCenter
+                    | otherwise = ypos
+
+
+ 
+
+updateScopeZoom :: World -> World
+updateScopeZoom w 
+    | SDL.ButtonRight `S.member` _mouseButtons w = case w ^? scppoint of
+        Just x 
+           | x > 9     -> zoomInLongGun $ zoomInLongGun
+                            $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just . scopeZoomChange -~ 2
+           | x > 0     -> zoomInLongGun
+                            $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just . scopeZoomChange -~ 1
+           | x < -9    -> zoomOutLongGun $ zoomOutLongGun
+                            $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just . scopeZoomChange +~ 2
+           | x < 0     -> zoomOutLongGun $ zoomOutLongGun
+                            $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just . scopeZoomChange +~ 1
+           | otherwise -> w
+        _                  -> w
+    | otherwise = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just %~ updateScope
+    where scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just . scopeZoomChange
+          updateScope (ItScope _ _ _ bl) = ItScope (0,0) 0 1 bl
+          updateScope otherAtt = otherAtt
+
+zoomSpeed = 39/40
+
+zoomInLongGun :: World -> World
+zoomInLongGun w | currentZoom < 8 = over (wpPointer . itAttachment . _Just . scopePos)
+                         (\p -> p +.+ (4-(4*zoomSpeed)) / currentZoom *.* mousep) 
+                        $ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z / zoomSpeed)
+                        w
+                | otherwise = w
+    where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+          wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0))
+          Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
+          mousep = rotateV (_cameraRot w) $ _mousePos w
+
+zoomOutLongGun :: World -> World
+zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just . scopePos)
+--                         (\p -> p -.- 2/(2 * currentZoom) *.* _mousePos w) 
+--                            (\p -> p -.- 2*zoomSpeed/currentZoom *.* p)
+                            (\p -> p)
+                        $ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z * zoomSpeed)
+                        w
+                 | otherwise = w
+    where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+          wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0))
+          Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
+          currentCursorDisplacement = fromJust $ _itAttachment wp
+
+rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . zoomCam
+
+rotateCameraL :: World -> World
+rotateCameraL w | SDL.KeycodeQ `S.member` _keys w
+                    = w & cameraRot +~ 0.015
+                        & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just . scopePos %~ rotateV 0.015
+                | otherwise = w
+rotateCameraR :: World -> World
+rotateCameraR w | SDL.KeycodeE `S.member` _keys w
+                    = w & cameraRot -~ 0.015
+                        & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+                                . itAttachment . _Just . scopePos %~ rotateV (-0.015)
+                | otherwise = w
+zoomCamIn :: World -> World
+zoomCamIn w | SDL.KeycodeJ `S.member` _keys w
+                    = w {_cameraZoom = _cameraZoom w + 0.01}
+            | otherwise = w
+zoomCamOut :: World -> World
+zoomCamOut w | SDL.KeycodeK `S.member` _keys w
+                    = w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
+             | otherwise = w
+
+-- the 395 here limits the max zoom out, is 25 less than the current screen
+-- size, thus matches up with it
+zoomCam :: World -> World
+--zoomCam w = w
+zoomCam w = over cameraZoom changeZoom w
+    where maxViewDistance = 800
+          camPos = _cameraCenter w
+          camRot = _cameraRot w
+          wallZoom = min (halfWidth w / (horizontalMax+10) ) 
+                                  (halfHeight w / (verticalMax+10) )
+          idealZoom | SDL.ButtonRight `S.member` _mouseButtons w 
+                        = scZoom * 
+                            (
+                            min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax)
+                              $ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin)
+                                    (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac))
+                            )
+                    | otherwise
+                        = min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
+                              $ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
+                                    (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac))
+          changeZoom curZoom | curZoom > idealZoom + 0.01 = 0.05 * (19*curZoom + idealZoom)
+                             | curZoom < idealZoom - 0.01 = 0.05 * (19*curZoom + idealZoom)
+                             | otherwise                  = idealZoom
+--          zs = take 20 [-maxViewDistance,0 - 0.9*maxViewDistance..]
+          zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
+          rRays = rotF [( maxViewDistance,y) | y <- zs]
+          lRays = rotF [(-maxViewDistance,y) | y <- zs]
+          tRays = rotF [(y, maxViewDistance) | y <- zs]
+          bRays = rotF [(y,-maxViewDistance) | y <- zs]
+          rotF = map (h . (+.+) camPos . rotateV (_cameraRot w))
+          h p = fromMaybe p $ collidePointIndirect camPos p $ wallsAlongLine camPos p w
+          h' x p = dotV (rotateV camRot x) (p -.- camPos)
+          horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays
+          verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays
+          scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom
+
+dirRays :: Float -> [Point2]
+dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0)

src/Dodge/CreatureActions.hs

@@ -0,0 +1,362 @@
+{-# LANGUAGE BangPatterns #-}
+module Dodge.CreatureActions where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+import Dodge.WorldActions
+
+import Geometry
+import Picture
+
+import Control.Lens
+import Control.Monad
+import Control.Applicative
+
+import Data.Maybe
+import Data.List
+
+import System.Random
+
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+-- }}}
+
+moveForwardSpeed :: Float -> Int -> World -> World
+moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w
+    where p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n
+
+mvForward :: Float -> Int -> World -> World
+mvForward speed cid w = stepForward cid speed $ over (creatures . ix cid . crPos) (+.+ p) w
+    where p =  (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir $ _creatures w IM.! cid
+          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid
+
+crStrafeLeft :: Float -> Creature -> Creature
+crStrafeLeft speed cr = stepForward' s2 $ over crPos (+.+ p) cr
+    where p =  (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2)
+          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+          s2 = (speed * equipFactor)
+crStrafeRight :: Float -> Creature -> Creature
+crStrafeRight speed cr = stepForward' s2 $ over crPos (+.+ p) cr
+    where p =  (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2)
+          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+          s2 = (speed * equipFactor)
+
+crMvForward :: Float -> Creature -> Creature
+crMvForward speed cr = over crPos (+.+ p) cr
+    where p =  (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr
+          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+
+crMvBy :: Point2 -> Creature -> Creature
+crMvBy p' cr = stepForward' (magV p) $ over crPos (+.+ p) cr
+    where p =  (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
+          equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
+          aimingFactor | (_posture $ _stance $ _crState cr) == Aiming
+                            = fromMaybe 1 $ it ^? itAimingSpeed
+                       | otherwise = 1
+          it = _crInv cr IM.! _crInvSel cr
+
+stepForward :: Int -> Float -> World -> World
+stepForward cid speed = over (creatures . ix cid . crState . stance . carriage) f
+    where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
+          f s = s
+
+stepForward' :: Float -> Creature -> Creature
+stepForward' speed cr = over (crState . stance . carriage) f cr
+    where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
+          f s = s
+
+equipSpeed NoItem = 1
+equipSpeed it | _itIdentity it == FrontArmour = 0.75
+              | _itIdentity it == FlameShield = 0.75
+              | otherwise                     = 1
+
+turnTo :: Point2 -> Int -> World -> World
+turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
+    where cr = _creatures w IM.! n
+          dirToTarget = argV (p -.- _crPos cr)
+
+turnToward :: Point2 -> Int -> World -> World
+turnToward p n w | isLeftOfA dirToTarget (_crDir cr)
+                             = f $ over (creatures . ix n . crDir) 
+                                        (normalizeAngle . (+ (0.03 + r*m))) w
+                 | otherwise = f $ over (creatures . ix n . crDir) 
+                                        (\x->normalizeAngle (x - (0.03 + r*m))) w
+                    where cr          = _creatures w IM.! n
+                          dirToTarget = argV (p -.- _crPos cr)
+                          (r,g)       = randomR (-0.1,0.1) (_randGen w)
+                          m           = diffAngles dirToTarget (_crDir cr)
+                          f           = set randGen g
+
+turnTowardAngle :: Float -> Int -> World -> World
+turnTowardAngle a n w 
+    | isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir) 
+                                        (normalizeAngle . (+ (0.03 + r*m))) w
+    | otherwise = f $ over (creatures . ix n . crDir) 
+                                        (\x->normalizeAngle (x - (0.03 + r*m))) w
+                    where cr          = _creatures w IM.! n
+                          (r,g)       = randomR (-0.1,0.1) (_randGen w)
+                          m           = diffAngles a (_crDir cr)
+                          f           = set randGen g
+
+turnToward'' :: Float -> Point2 -> Int -> World -> World
+turnToward'' turnSpeed p n w 
+    | isLeftOfA dirToTarget (_crDir cr)
+                = f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w
+    | otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w
+                    where cr          = _creatures w IM.! n
+                          dirToTarget = argV (p -.- _crPos cr)
+                          (r,g)       = randomR (-0.1,0.1) (_randGen w)
+                          f           = set randGen g
+
+crTurnAndStrafeIn :: Float -> Float -> Point2 -> Creature -> Creature
+crTurnAndStrafeIn strafeSpeed turnSpeed p cr
+    | vToTarg == (0,0) = cr -- this should deal with the angleVV error
+    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
+                = set crDir dirToTarget cr
+    | isLeftOfA dirToTarget (_crDir cr)
+                = over crDir (normalizeAngle . (+ turnAmount ))
+                      $ crStrafeLeft strafeSpeed cr
+    | otherwise = over crDir (\x->normalizeAngle (x - turnAmount))
+                      $ crStrafeRight strafeSpeed cr
+                    where vToTarg = p -.- _crPos cr
+                          dirToTarget = argV vToTarg
+                          turnAmount  = turnSpeed
+
+crTurnTo :: Point2 -> Creature -> Creature
+crTurnTo p cr = set crDir dirToTarget cr
+    where dirToTarget = argV (p -.- _crPos cr)
+
+crTurnTowardSpeed :: Float -> Point2 -> Creature -> Creature
+crTurnTowardSpeed turnSpeed p cr
+    | vToTarg == (0,0) = cr -- this should deal with the angleVV error
+    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
+                = set crDir dirToTarget cr
+    | isLeftOfA dirToTarget (_crDir cr)
+                = over crDir (normalizeAngle . (+ turnAmount )) cr
+    | otherwise = over crDir (\x->normalizeAngle (x - turnAmount)) cr
+                    where vToTarg = p -.- _crPos cr
+                          dirToTarget = argV vToTarg
+                          turnAmount  = turnSpeed
+
+turnTowardSpeed :: Float -> Point2 -> Int -> World -> World
+turnTowardSpeed turnSpeed p n w 
+    | vToTarg == (0,0) = w -- this should deal with the angleVV error
+    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
+                = set (creatures . ix n . crDir) dirToTarget w
+    | isLeftOfA dirToTarget (_crDir cr)
+                = over (creatures . ix n . crDir) (normalizeAngle . (+ turnAmount )) w
+    | otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - turnAmount)) w
+                    where cr          = _creatures w IM.! n
+                          vToTarg = p -.- _crPos cr
+                          dirToTarget = argV vToTarg
+                          turnAmount  = turnSpeed
+
+turnLRS :: Int -> World -> World
+turnLRS n w = f $ over (creatures . ix n . crDir) (+ (fromIntegral r * pi / 2)) w
+    where (r,g) = randomR (negate 1::Int,1) (_randGen w)
+          f     = set randGen g
+
+turnToward' :: Point2 -> Int -> World -> World
+turnToward' p n w | isLeftOfA dirToTarget (_crDir cr)
+                              = over (creatures . ix n . crDir) (+ 0.03) w
+                  | otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w
+                    where cr          = _creatures w IM.! n
+                          dirToTarget = argV (p -.- _crPos cr)
+
+overturnToward :: Point2 -> Int -> World -> World
+overturnToward  p n w 
+                | isLeftOfA dirToTarget (_crDir cr)
+                            = over (creatures . ix n . crDir) (normalizeAngle. (+ 0.03 )) w
+                | otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - 0.03 )) w
+                    where cr          = _creatures w IM.! n
+                          dirToTarget = argV (p -.- _crPos cr)
+
+moveForward :: Int -> World -> World
+moveForward n w = over (creatures . ix n . crPos) (+.+ p) w
+    where p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
+
+moveToward :: Point2 -> Int -> World -> World
+moveToward p n w
+    | angle < 10 = moveForwardSpeed 0.1 n w
+    | angle < 20 = moveForwardSpeed 0.02 n w
+    | angle < 40 = moveForwardSpeed 0.01 n w
+    | otherwise  = w
+        where angle  = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n)))
+              curPos = _crPos (_creatures w IM.! n)
+
+moveBy :: Int -> Point2 -> World -> World
+moveBy n v = over (creatures . ix n . crPos) (+.+ v)
+
+reloadWeapon :: Int -> World -> Maybe World
+reloadWeapon cid w = if _unlimitedAmmo w then reloadWeaponUnlimited cid w
+                                         else reloadWeaponAmmoCheck cid w
+
+reloadWeaponUnlimited :: Int -> World -> Maybe World
+reloadWeaponUnlimited cid w = 
+    let cr = _creatures w IM.! cid
+        it = _crInv cr IM.! _crInvSel cr
+        itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
+    in case it of 
+        Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpReloadState=rS,_wpReloadTime=rT} 
+            | lA < maxA && rS == 0 -> Just $ set ( itRef . wpLoadedAmmo) maxA
+                                            $ set ( itRef . wpReloadState) rT w
+        _                          -> Nothing
+
+reloadWeaponAmmoCheck :: Int -> World -> Maybe World
+reloadWeaponAmmoCheck cid w = 
+    let cr = _creatures w IM.! cid
+        it = _crInv cr IM.! _crInvSel cr
+        itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
+    in  case it of 
+            Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpAmmoType=aT
+                   ,_wpReloadState=rS ,_wpReloadTime=rT} 
+                ->  do guard $ lA < maxA && rS == 0 && M.findWithDefault 0 aT (_crAmmo cr) > 0
+                       toAdd <- Just $ min (_crAmmo (you w) M.! aT) (maxA - lA)
+                       return $ over (creatures . ix cid . crAmmo) (M.adjust (\x -> x - toAdd) aT)
+                              $ over ( itRef . wpLoadedAmmo) (\x -> x + toAdd)
+                              $ set ( itRef . wpReloadState) rT w
+            _   -> Nothing
+
+
+useItemContinuous :: Int -> World -> World
+useItemContinuous n w = case (_crInv cr IM.! _crInvSel cr) ^? itHammer of
+                            Just HammerUp -> useItem1 n $ setHammerDown w
+                            Just NoHammer -> useItem1 n w
+                            _             -> setHammerDown w
+    where 
+        cr = _creatures w IM.! n
+        setHammerDown = creatures . ix n . crInv . ix (_crInvSel cr) . itHammer .~ HammerDown
+
+tryUseItem :: Int -> World -> World
+tryUseItem cid w = case w ^? creatures . ix cid of
+    Just cr -> useItem2 cid (_crInv cr IM.! _crInvSel cr) w
+    Nothing -> w
+
+useItem1 :: Int -> World -> World
+useItem1 n w = useItem2 n it w
+    where c = (_creatures w IM.! n)
+          it = _crInv c IM.! _crInvSel c
+
+useItem2 :: Int -> Item -> World -> World
+useItem2 n (Consumable {_cnEffect=eff }) w = fromMaybe w $ fmap (rmInvItem n) $ eff n w
+useItem2 n (Weapon {_wpFire=eff}) w = eff n w
+useItem2 n (Throwable {_twFire = eff}) w = eff n w
+useItem2 _ _ w = w
+
+rmInvItem :: Int -> World -> World
+rmInvItem n w = 
+    let i = _crInvSel (_creatures w IM.! n)
+        item = _crInv (_creatures w IM.! n) IM.! i
+        itRef = creatures . ix n . crInv . ix i
+    in  case item of
+            Consumable {_itAmount = 1} -> set itRef NoItem w    
+            Craftable {_itAmount = 1} -> set itRef NoItem w    
+            Equipment {_itAmount = 1} -> set itRef NoItem w    
+            Throwable {_itAmount = 1} -> set itRef NoItem w    
+            Consumable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w    
+            Craftable {_itAmount = x} -> over (itRef . itAmount)  (\y-> y-1) w    
+            Equipment {_itAmount = x} -> over (itRef . itAmount)  (\y-> y-1) w    
+            Throwable {_itAmount = x} -> over (itRef . itAmount)  (\y-> y-1) w    
+            _ -> set itRef NoItem w
+
+dropItem :: World -> World
+dropItem w = case yourItem w of
+    NoItem -> w
+    it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
+                            $ updateLocation
+                            $ soundOnce putDownSound 
+                            $ set randGen g w
+      where (rot, g) = randomR (-pi,pi) $ _randGen w
+            offset = _crRad (you w) *.* unitVectorAtAngle rot
+            updateLocation w = case it ^? itID of
+                                  Just (Just i)  -> w & itemPositions . ix i .~ OnFloor flid
+                                  _ -> w
+            flid = newKey $ _floorItems w
+            theflit = FlIt {_flIt = set itAmount 1 it
+                            ,_flItPos = offset +.+ _crPos (you w)
+                            ,_flItRot = rot
+                            ,_flItID = flid}
+
+useItemAmmoCheck :: Int -> World -> World
+useItemAmmoCheck n w 
+    | hasAmmo   = useItem1 n w
+    | otherwise = w
+        where c = _creatures w IM.! n
+              hasAmmo = case _crInv c IM.! _crInvSel c of
+                             Weapon {_wpLoadedAmmo=0, _wpAmmoType=ammoT}
+                                       -> case _crAmmo c M.!? ammoT of 
+                                            Just x -> x > 0 
+                                            _      -> False
+                             Weapon {} -> True
+                             _         -> False
+
+
+closestItem :: World -> Maybe Int
+closestItem w = fmap fst $ listToMaybe $ sortBy cf $ IM.toList 
+                    $ fmap (dist yourP . _flItPos) $ _floorItems w
+    where yourP = _crPos $ you w
+          cf (_,x) (_,y) = compare x y
+
+pickUpItem' :: FloorItem -> World -> World
+pickUpItem' flit w = case maybeInvSlot of
+    Nothing -> w
+    Just i  -> soundOnce pickUpSound
+               $ updateItLocation i
+               $ w & floorItems %~ IM.delete (_flItID flit)
+                   & creatures . ix 0 . crInv . ix i %~ addItem' it
+    where 
+        it = _flIt flit
+        maybeInvSlot = checkInvSlots it (_crInv (_creatures w IM.! 0))
+        updateItLocation invid w' 
+            = case _itID it of Nothing -> w'
+                               Just j  -> w' & itemPositions . ix j .~ InInv 0 invid
+
+checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int
+checkInvSlots it its = fmap fst $ find cond $ IM.toList its
+    where cond (_,NoItem) = True
+          cond (_,it'   ) = itNotFull it' && _itName it == _itName it'
+
+addItem' :: Item -> Item -> Item
+addItem' it NoItem = it
+addItem' it it'    = it' & itAmount +~ 1
+
+numInventorySlots :: Int 
+numInventorySlots = 9
+
+itNotFull :: Item -> Bool
+itNotFull it = _itMaxStack it > _itAmount it
+
+createItemAt :: Point2 -> FloorItem -> World -> World
+createItemAt p it w = over floorItems (IM.insert i (set flItPos p 
+                                                    $ set flItID i it)) w
+    where i = newKey (_floorItems w)
+
+blinkAction :: Int -> World -> World
+blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
+                    $ blinkShockwave p3
+                    $ inverseShockwaveAt cp 40 2 2 2 
+                        w
+    where   p1 = _cameraPos w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
+            cp = _crPos $ _creatures w IM.! n
+            p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w
+            r  = 1.5 * _crRad (_creatures w IM.! n)
+            p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
+
+blinkShockwave :: Point2 -> World -> World
+blinkShockwave p = makeShockwaveAt p 40 1 2 cyan 
+
+moveAmountToward :: Point2 -> Float -> Point2 -> Point2
+moveAmountToward p1 am p2
+    = p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1)
+
+facePointAI :: Point2 -> Int -> World -> World
+facePointAI p n w = set (creatures . ix n . crDir) 
+                        (argV (p -.- _crPos (_creatures w IM.! n)) )
+                        w
+
+reverseDir :: Int -> World -> World
+reverseDir n = over (creatures . ix n . crDir) (+ pi)
+
+turnBy :: Float -> Int -> World -> World
+turnBy a n = over (creatures . ix n . crDir) (+ a)

src/Dodge/CreatureState.hs

@@ -0,0 +1,245 @@
+module Dodge.CreatureState where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+import Dodge.RandomHelp
+import Dodge.WorldActions
+import Dodge.WallCreatureCollisions
+import Dodge.CreatureActions
+
+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 Data.Graph.Inductive.Query.SP
+import Codec.BMP
+import qualified Data.ByteString as B
+import Control.Lens
+import Control.Applicative
+import Control.Monad.State
+import Control.Monad
+import qualified SDL as SDL
+import qualified SDL.Mixer as Mix
+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
+---}
+  
+type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
+
+-- the movement is updated before the ai in order to correctly set the oldpos
+-- the whole of this update cycle could do with a rethink, it is becoming
+-- convoluted
+stateUpdate :: CRUpdate -> CRUpdate
+stateUpdate u w (f,g) cr = case u w (f,g) (updateMovement g cr) of
+        ((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . dropifdead . f'
+                                 , g')
+                               , fmap (updateReloadCounter . reducePastDamage . doDamage) 
+                                      $ crOrCorpse =<< maybeCr
+                               )
+    where   
+        crOrCorpse cr | cr ^. crHP > 0 = Just cr
+                      | otherwise      = Nothing
+        dropifdead | cr ^.crHP > 0 = id
+                   | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) 
+                                    . over decorations addCorpse 
+                                    . insertIt
+        crBeforeDeath = colCrWall w $ cr
+--        addCorpse = insertNewKey $ uncurry translateDrawing (_crPos crBeforeDeath) 
+        addCorpse = insertNewKey $ uncurry translateDrawing (_crOldPos cr) 
+                                 $ rotateDrawing (radToDeg (_crDir cr))
+                                 (_crCorpse cr)
+        maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w)
+        insertIt = case maybeIt of 
+--                      Just it -> createItemAt (offset +.+ _crPos crBeforeDeath) 
+                      Just it -> createItemAt (offset +.+ _crOldPos cr) 
+                                              (FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0})
+                      Nothing -> id
+        offset = _crRad cr *.* unitVectorAtAngle rot
+        (rot,_) = randomR (-pi,pi) g
+
+
+setOldPos :: Creature -> Creature
+setOldPos cr = set crOldPos (_crPos cr) cr
+
+doDamage :: Creature -> Creature
+doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost) 
+                                            damagedCr
+    where dams = _crDamage $ _crState cr
+          startHP = _crHP cr
+          damagedCr = snd $ (_crApplyDamage (_crState cr)) dams cr
+-- applyDamage (cr ^. crState . crDamage) cr
+          afterHP = _crHP damagedCr
+          hpLost = startHP - afterHP  -- note this can be negative 
+--          applyDamage :: DamageType -> Creature -> Creature
+--          applyDamage dt cr = snd $ (cr ^. crState . crApplyDamage) dt cr
+
+sumDamage :: Creature -> DamageType -> Int -> Int
+sumDamage cr dm x = x + _dmAmount dm
+
+reducePastDamage :: Creature -> Creature
+reducePastDamage = over (crState . crPastDamage) rdpdam
+    where rdpdam x  | x > 500 = x - 55
+                    | x > 200 = x - 25
+                    | x > 20  = x - 5
+                    | x > 0   = x - 1
+                    | otherwise = 0
+
+
+
+movementSideEff :: Creature -> World -> World
+movementSideEff cr w
+    | hasJetPack 
+        = case cr ^? crState . stance . carriage of
+            Just (Boosting v) 
+                -> makeFlamelet (oldPos +.+ (_crRad cr + 3) *.* (unitVectorAtAngle $ _crDir cr + pi))
+                                (momentum +.+ 1 *.* rotateV randDir (vInverse v)) 
+                                66
+                                Nothing
+                                1
+--                    $ smokeGen v
+                    $ set randGen g
+                        w
+            _   -> w
+    | otherwise = case cr ^? crState . stance . carriage of
+                    Just (Walking x y) -> takeStep x y w
+                    _ -> w
+        where hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr
+              oldPos = _crOldPos cr
+              momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
+              momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
+                         | otherwise          = momentum'
+              momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
+              (randDir,g) = randomR (-0.5,0.5) $ _randGen w
+              (randAng,_) = randomR (0,2*pi) $ _randGen w
+
+              (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w
+              (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[])
+              (t1:t2:t3:_) = randomRs ( 15,20) $ _randGen w
+              (s1:s2:s3:_) = map (\s -> fromIntegral s * 0.1 - 1) (t3:t2:t1:[])
+              smokeGen v =  makeSmokeAt'' v1 s1 t1 
+                                (r1 +.+ oldPos +.+ ((_crRad cr + 3) *.* vInverse (unitVectorAtAngle $ _crDir cr)))
+
+              crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5
+              takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0
+                           | crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0  
+                           | otherwise = id
+              footor = [FootstepSound 0,FootstepSound 1]
+
+invSideEff :: Creature -> World -> World
+invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
+    where f i it w' = case it ^? itEffect . itInvEffect of
+                            Nothing -> w'
+                            Just g  -> g cr i w'
+
+weaponReloadSounds :: Creature -> World -> World
+weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of
+                              Just (Weapon {_wpReloadState = 0})
+                                 -> w
+                              Just (Weapon {_wpReloadState = 1})
+                                 -> stopSoundFrom (CrReloadSound cid) w
+                              Just (Weapon {})
+                                 -> soundFrom (CrReloadSound cid) reloadSound (1) 0 w
+                              _
+                                 -> w
+      where cid = _crID cr
+
+updateMovement :: StdGen -> Creature -> Creature
+updateMovement g cr 
+            | isFrictionless cr = over crPos (+.+ momentum) 
+                              $ setOldPos
+                              cr
+            | otherwise 
+              = case cr ^? crState . stance . carriage of
+                  Just (Walking x y) 
+                      -> set (crState . stance . carriage) (Walking ((x+y)`mod`120) 0)
+                          $ setOldPos
+                          cr
+                  _  -> set (crState . stance . carriage) (Walking 0 0)
+                          $ setOldPos
+                          cr
+    where
+        momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
+        momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
+                   | otherwise          = momentum'
+        momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
+        (randAng,_) = randomR (0,2*pi) g
+
+isFrictionless :: Creature -> Bool
+isFrictionless cr = case cr ^? crState . stance . carriage of
+    Just (Boosting _) -> True
+    Just (Floating)   -> True
+    _                 -> False
+
+updateReloadCounter :: Creature -> Creature
+updateReloadCounter cr = over (crInv . ix iSel . wpFireState) decreaseToZero
+                            . over (crInv . ix iSel . wpReloadState) decreaseToZero
+                            $ cr
+     where iSel = _crInvSel cr 
+
+decreaseToZero :: Int -> Int
+decreaseToZero x | x > 0     = x - 1
+                 | otherwise = 0
+
+updateBarrel :: 
+    World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
+updateBarrel w (f,g) cr | _crHP cr > 0 = ((f, g), newCr)
+                        | otherwise   = ((f, g), Nothing)
+--                    | otherwise   = ((makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing)
+    where damages = _crDamage $ _crState cr
+          newCr = Just $ doDamage cr
+
+-- it is easy to leave off the "f" here 
+-- should find some better way of doing all this that is less prone to error
+updateExpBarrel :: 
+    World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
+updateExpBarrel w (f,g) cr 
+    | _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr)
+    | otherwise   = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing)
+    where damages = _crDamage $ _crState cr
+          pierceSparks :: [World -> World]
+          pierceSparks 
+            = zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p)) 
+                                                (Just $ _crID cr))
+                                  poss as colids times
+          as =  randomRs (-0.7,0.7) $ g
+          colids = randomRs (0,11) $ g
+          times = randomRs (2,5) $ g
+          (g',_) = split g
+          poss = _piercedPoints $ _crSpState $ _crState cr
+          --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages
+          newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr
+          perforate :: DamageType -> Creature -> Creature
+          perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
+                                                            ((:) $ int -.- _crPos cr) cr
+          perforate _ cr = cr
+          applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints 
+                                                             $ _crSpState $ _crState cr)) 
+                                         cr
+          hiss | poss == [] = id
+               | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
+          stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
+
+damToExpBarrel :: [DamageType] -> Creature -> Creature
+damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
+    where (pierceDam,otherDam) = partition isPierce ds
+          isPierce (Piercing {}) = True
+          isPierce _             = False
+
+damToExpBarrel' :: DamageType -> Creature -> Creature
+damToExpBarrel' (Piercing amount sp int ep) cr 
+    = over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr) 
+        $ over crHP (\hp -> hp - div amount 200) cr
+damToExpBarrel' (PoisonDam {}) cr = cr
+damToExpBarrel' (SparkDam {})  cr = cr
+damToExpBarrel' (PushDam {_dmPushBack = v})   cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v)
+damToExpBarrel' dt             cr = cr Control.Lens.& crHP -~ _dmAmount dt

src/Dodge/Critters.hs

@@ -0,0 +1,399 @@
+module Dodge.Critters where
+-- imports {{{
+import Dodge.Data
+import Dodge.Weapons
+import Dodge.AIs
+import Dodge.CreatureState
+import Dodge.Prototypes
+import Dodge.Base
+import Dodge.Smoke
+
+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 (greyN 0.8) $ circleSolid 10, color col $ circLine 10]
+colouredEnemy col = pictures [color col $ circleSolid 10, circLine 10]
+
+
+--  armouredSwarmCrit :: Int -> Creature
+--  armouredSwarmCrit n = (basicCreature n)
+--  --    { _crUpdate = encircleAI' n
+--      { _crUpdate = swarmAI lineOrth n
+--      , _crHP = 30
+--      , _crPict = equipOnTop goalPict
+--      , _crState = basicState {_goals = [[]], _faction = EncircleFlock}
+--      , _crInv = IM.fromList [(0,frontArmour)]
+--      }
+--  
+--  swarmCrit :: Int -> Creature
+--  swarmCrit n = (basicCreature n)
+--  --    { _crUpdate = encircleAI' n
+--      { _crUpdate = swarmAI lineOrth n
+--      , _crHP = 30
+--      , _crPict = equipOnTop goalPict
+--      , _crState = basicState {_goals = [[]], _faction = EncircleFlock}
+--      , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+--      }
+--  
+--  encircleCrit :: Int -> Creature
+--  encircleCrit n = (basicCreature n)
+--  --    { _crUpdate = encircleAI' n
+--      { _crUpdate = swarmAI lineOrth n
+--      , _crHP = 30
+--      , _crPict = equipOnTop goalPict
+--      , _crState = basicState {_goals = [[]], _faction = EncircleFlock}
+--      , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+--      }
+--  
+spawnerCrit :: Creature
+spawnerCrit = basicCreature
+    { _crUpdate = stateUpdate $ spawnerAI chaseCrit
+    , _crHP = 300
+    , _crPict = enemyPict blue
+    , _crState = basicState {_goals = [[WaitFor 0]]
+                            }
+    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+    }
+--  
+--  guardMelee :: Int -> Creature
+--  guardMelee n = (basicCreature n)
+--      { _crUpdate = meleeAI' n
+--      , _crHP = 30
+--      , _crPict = equipOnTop goalPict
+--      , _crState = basicState {_goals = [[InitGuard]]
+--                              ,_faction = ChaseCritters}
+--      , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+--      }
+smallChaseCrit :: Creature
+smallChaseCrit = basicCreature
+    { _crUpdate = stateUpdate chaseAI
+    , _crHP = 1
+    , _crRad = 4
+    --, _crPict = equipOnTop goalPict
+    , _crPict = enemyPict green
+    , _crState = basicState {_goals = [[Wait]]
+                            ,_faction = ChaseCritters}
+    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4
+    }
+chaseCrit :: Creature
+chaseCrit = basicCreature
+    { _crUpdate = stateUpdate chaseAI
+    , _crHP = 300
+--    , _crPict = goalPict -- enemyPict green
+    , _crPict = enemyPict green
+    , _crState = basicState {_goals = [[Wait]]
+                            ,_faction = ChaseCritters}
+    , _crInv = IM.empty 
+             --  IM.fromList [(0,frontArmour)]
+    }
+armourChaseCrit :: Creature
+armourChaseCrit = basicCreature
+    { _crUpdate = stateUpdate chaseAI
+    , _crHP = 300
+    , _crPict = enemyPict green
+    , _crState = basicState {_goals = [[Wait]]}
+    , _crInv = IM.fromList [(0,frontArmour)]
+    }
+miniGunCrit :: Creature
+miniGunCrit = basicCreature
+    { _crPict = enemyPict red
+    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crUpdate = stateUpdate  miniAI
+    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crInv = IM.fromList [(0,miniGun)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+    --, _crState = ShooterWait
+    , _crState = basicState {_goals = [[InitGuard]]}
+    , _crHP = 500
+    }
+longCrit :: Creature
+longCrit = basicCreature
+    { _crPict = enemyPict red
+    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crUpdate = stateUpdate sniperAI
+    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crInv = IM.fromList [(0,longGun),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+    --, _crState = ShooterWait
+    , _crState = basicState {_goals = [[InitGuard]]}
+    , _crHP = 300
+    }
+multGunCrit :: Creature
+multGunCrit = basicCreature
+    { _crPict = enemyPict red
+    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crUpdate = stateUpdate (twitchMissAI 300 350)
+    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crInv = IM.fromList [(0,multGun),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+    --, _crState = ShooterWait
+    , _crState = basicState {_goals = [[InitGuard]]}
+    , _crHP = 300
+    }
+launcherCrit :: Creature
+launcherCrit = basicCreature
+    { _crPict = enemyPict red
+    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crUpdate = stateUpdate (launcherAI 150 200)
+    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crInv = IM.fromList [(0,launcher),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+    --, _crState = ShooterWait
+    , _crState = basicState {_goals = [[Init]]}
+    , _crHP = 300
+    }
+spreadGunCrit :: Creature
+spreadGunCrit = basicCreature
+    { _crPict = enemyPict red
+    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crUpdate = stateUpdate chargeAI
+    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crInv = IM.fromList [(0,spreadGun),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+    --, _crState = ShooterWait
+    , _crState = basicState {_goals = [[Init]]}
+    , _crHP = 300
+    }
+pistolCrit :: Creature
+pistolCrit = basicCreature
+    { _crPict = enemyPict red
+    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crUpdate = stateUpdate (dodgeAI 150 200)
+    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
+    , _crInv = IM.fromList [(0,pistol),(1,medkit 100)]
+    , _crInvSel = 0
+    , _crRad = 10
+    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+    --, _crState = ShooterWait
+    , _crState = basicState {_goals = [[InitGuard]]}
+    , _crHP = 500
+    }
+autoCrit :: Creature
+autoCrit = basicCreature
+    { _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
+    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+    --, _crState = ShooterWait
+    , _crState = basicState {_goals = [[InitGuard]]}
+    , _crHP = 300
+    }
+addArmour :: Creature -> Creature
+addArmour = over crInv insarmour
+    where insarmour xs = IM.insert i frontArmour xs
+            where i = newKey xs
+--closeShooterCrit :: Int -> Creature
+--closeShooterCrit n = (basicCreature n)
+--    { _crPos = startPos
+--    , _crPict = equipOnTop goalPict
+--    , _crUpdate =  closeShooterAI n
+--    , _crInv = IM.fromList [(0,ltAutoGun)]
+--    , _crInvSel = 0
+--    , _crRad = 10
+--    , _crAmmo = M.fromList [(PistolBullet, 1000)]
+--    , _crState = basicState {_goals = [[InitGuard]]}
+--    , _crHP = 50
+--    }
+--    where startPos = (20*fromIntegral n-550,0)
+barrel :: Creature
+barrel = basicCreature
+    { _crUpdate = updateBarrel
+    , _crHP = 500
+    , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10
+                                , color (greyN 0.5) $ circleSolid 8
+                                ]
+    , _crState = basicState {_goals = [[Wait]]
+                            ,_faction = ChaseCritters
+                            ,_crSpState = Barrel []
+                            }
+    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+    }
+
+explosiveBarrel :: Creature
+explosiveBarrel = basicCreature
+    { _crUpdate = updateExpBarrel
+    , _crHP = 400
+    , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10
+                                , color red $ circleSolid 8
+                                ]
+    , _crState = basicState {_goals = [[Wait]]
+                            ,_faction = ChaseCritters
+                            ,_crSpState = Barrel []
+                            ,_crApplyDamage = \_ c -> (id, c)
+                            }
+    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
+    }
+
+equipOnTop :: (Creature -> Picture) -> Creature -> Drawing
+--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
+equipOnTop f cr = onLayer CrLayer (f cr) <> drawEquipment cr
+
+drawEquipment :: Creature -> Drawing
+drawEquipment cr = mconcat $ 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
+--                             ,color (greyN 0.1) $ thickArc 0 90 20 5
+--                             ,color (greyN 0.1) $ thickArc 270 360 20 5
+                             ]
+
+--packCrits :: (Int -> World -> World) -> [Int] -> [Creature]
+--packCrits ai is = [(basicCreature 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 = (basicCreature 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 = (basicCreature 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 (radToDeg (_crDir cr)) $ scale 0.1 0.1 $ color white $ text $ show gls]
+    _                  -> sizeColEnemy r (light $ dim green)
+
+startCr :: Creature
+startCr = basicCreature
+    { _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] 
+                           ([pistol,autoGun,launcher,lasGun,grenade
+                            ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
+                            ,longGun
+                            ,hvAutoGun
+                            ,teslaGun
+                            ,latchkey 0
+                            ] 
+                            ++ repeat NoItem)) 
+                          -- startInv
+    , _crAmmo = M.fromList [(PistolBullet, 0),(LiquidFuel, 100),(Battery, 20000),(Shell,200)]
+    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
+    }
+
+smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor
+
+enemyPict :: Color -> Creature -> Drawing
+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 -> Drawing
+basicCrPict col cr = 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]
+--                                     , rotate (radToDeg $ _crDir cr) $ scale 0.2 0.2 $ color white $ text $ show $ _crPos cr
+          pdam = _crPastDamage $ _crState cr

src/Dodge/Data.hs

@@ -0,0 +1,715 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+--{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data 
+    ( module Dodge.Data
+    , Point2 (..)
+    )
+    where
+-- imports {{{
+
+import Picture.Data
+
+import Geometry.Data
+
+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 (Keycode, MouseButton)
+import Graphics.Rendering.OpenGL (PrimitiveMode (..),GLfloat,Program,VertexArrayObject,BufferObject)
+import Codec.Picture (Image,PixelRGBA8)
+
+import qualified Data.DList as DL
+
+--}}}
+-- datatypes {{{
+
+
+
+
+data World = World 
+                { _keys :: !(S.Set Keycode)
+                , _mouseButtons :: !(S.Set MouseButton)
+                , _cameraPos :: !Point2
+                , _cameraAimTime :: Int
+                , _cameraRot :: !Float
+                , _cameraZoom :: !Float
+                , _cameraCenter :: !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))
+                , _particles :: IM.IntMap Particle
+                , _particles' :: ![Particle']
+                , _afterParticles' :: ![Particle']
+                , _smoke :: [Smoke]
+                , _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]
+--                , _loadedSounds :: IM.IntMap Mix.Chunk
+                , _sounds :: M.Map SoundOrigin Sound
+                , _decorations :: IM.IntMap Drawing
+                , _corpses :: IM.IntMap (IM.IntMap [Corpse])
+                , _lbClickMousePos :: (Float,Float)
+                , _lbRotation :: Float
+                , _pathGraph :: ~(Gr Point2 Float)
+                , _pathGraph' :: ~[(Point2,Point2)]
+                , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
+                , _pathInc :: ~(M.Map Point2 [Point2])
+                , _unlimitedAmmo :: Bool
+                , _storedLevel :: Maybe World
+                , _menuState :: MenuState
+                , _worldState :: M.Map WorldState Bool
+                , _windowX :: Float
+                , _windowY :: Float
+                , _mapDisplay :: (Bool, Float)
+                , _lightSources :: !(IM.IntMap LightSource)
+                , _tempLightSources :: ![TempLightSource]
+                } --deriving (Show)
+
+type Drawing = Picture
+
+data Corpse = Corpse
+                { _cpPos :: Point2
+                , _cpPict :: Drawing
+                , _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 -> Drawing
+    , _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 -> Drawing
+                , _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
+                , _crAmmo :: M.Map Ammo Int
+                , _crState :: CreatureState
+                , _crCorpse :: Drawing
+                }
+
+data CreatureState 
+    = CrSt { _goals    :: [[Goal]]
+           , _stance  :: Stance
+           , _faction :: Faction
+           , _crDamage  :: [DamageType]
+           , _crPastDamage :: Int
+           , _crSpState :: CrSpState
+           , _crApplyDamage :: [DamageType] -> Creature -> (World -> World,Creature)
+           }
+--    deriving (Eq,Show)
+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
+
+data Sound = Sound { _soundTime :: Int
+                   , _soundFadeTime :: Int
+                   , _soundChannel :: Maybe Int
+                   , _soundPos :: Maybe Point2
+                   , _soundType :: Int
+                   }
+    deriving (Eq,Ord,Show)
+
+data Button = Button 
+                { _btPict :: Drawing
+                , _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 :: Drawing
+                             , _ppPos :: Point2
+                             , _ppRot :: Float
+                             , _ppEvent :: PressPlate -> World -> World
+                             , _ppID :: Int
+                             , _ppText :: String
+                             }
+
+data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int}
+               | FlAm { _flAm :: Ammo , _flItPos :: Point2 , _flAmNum :: Int , _flItID :: Int}
+
+data ItemPos =  InInv   { _itCrId :: Int
+                        , _itInvId :: Int
+                        }
+             | OnFloor  { _itFlID :: Int
+                        }
+
+data Item = Weapon
+            { _itName :: String
+            , _wpMaxAmmo :: Int
+            , _wpLoadedAmmo :: Int
+            , _wpAmmoType :: Ammo
+            , _wpReloadTime :: Int
+            , _wpReloadState :: Int
+            , _wpFireRate :: Int
+            , _wpFireState :: Int
+            , _wpFire :: Int -> World -> World
+            , _wpSpread :: Float
+            , _wpRange :: Float
+            , _itHammer :: HammerPosition
+            , _itFloorPict :: Drawing
+            , _itMaxStack :: Int
+            , _itAmount :: Int
+            , _itAimingSpeed :: Float
+            , _itAimingRange :: Float
+            , _itZoom :: ItZoom
+            , _itEquipPict :: Creature -> Int -> Drawing
+            , _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 :: Drawing
+            , _itEquipPict :: Creature -> Int -> Drawing
+            , _itIdentity :: ItemIdentity
+            , _itID :: Maybe Int
+            , _itInvDisplay :: Item -> String
+            , _itInvColor :: Color
+            , _itEffect :: ItEffect
+            , _itHammer :: HammerPosition
+            }
+          | Craftable
+            { _itName :: String
+            , _itMaxStack :: Int
+            , _itAmount :: Int
+            , _itFloorPict :: Drawing
+            , _itEquipPict :: Creature -> Int -> Drawing
+            , _itIdentity :: ItemIdentity
+            , _itID :: Maybe Int
+            , _itInvDisplay :: Item -> String
+            , _itInvColor :: Color
+            }
+          | Equipment
+            { _itName :: String
+            , _itMaxStack :: Int
+            , _itAmount :: Int
+            , _itFloorPict :: Drawing
+            , _itEquipPict :: Creature -> Int -> Drawing
+            , _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 :: Drawing
+            , _twMaxRange :: Float
+            , _twAccuracy :: Float
+            , _twFire :: Int -> World -> World
+            , _itAimingSpeed :: Float
+            , _itAimingRange :: Float
+            , _itZoom :: ItZoom
+            , _itEquipPict :: Creature -> Int -> Drawing
+            , _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}
+
+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' { _ptPict' :: Drawing
+           , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
+           }
+    | Bul'  { _ptPict' :: Drawing
+           , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
+           , _btVel' :: Point2
+           , _btColor' :: Color
+           , _btTrail' :: [Point2]
+           , _btPassThrough' :: Maybe Int
+           , _btWidth' :: Float 
+           , _btTimer' :: Int
+           , _btHitEffect' :: HitEffect'
+           }
+    | Pt'  { _ptPict' :: Drawing
+           , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
+           , _btVel' :: Point2
+           , _btColor' :: Color
+           , _btPos' :: Point2
+           , _btPassThrough' :: Maybe Int
+           , _btWidth' :: Float 
+           , _btTimer' :: Int
+           , _btHitEffect' :: HitEffect'
+           }
+    | Shockwave' 
+            { _ptPict'      :: Drawing
+            , _ptUpdate'    :: World -> Particle' -> (World, Maybe Particle')
+            , _btColor'     :: Color
+            , _btPos'       :: Point2
+            , _btRad'       :: Float
+            , _btDam'       :: Int
+            , _btPush'      :: Float
+            , _btMaxTime'   :: Int
+            , _btTimer'     :: Int
+            }
+
+type HitEffect = Point2 -> Point2 -> (Point2, (Either3 Creature Wall ForceField)) -> World -> World
+type HitEffect' = Particle' -> (Point2, (Either3 Creature Wall ForceField)) -> World -> World
+
+data Particle = 
+    Particle { _ptPos :: Point2
+             , _ptStartPos :: Point2
+             , _ptVel :: Point2
+             , _ptPict :: Drawing
+             , _ptID :: Int
+             , _ptUpdate :: World -> World
+             }
+    | Bullet { _ptPos :: Point2
+             , _ptVel :: Point2
+             , _ptPict :: Drawing
+             , _ptID :: Int
+             , _ptUpdate :: World -> World
+             , _btTrail :: [Point2]
+             , _btPassThrough :: Maybe Int
+             , _btColor :: Color
+             , _btWidth :: Float
+--             , _btHitEffect :: Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> World
+             }
+    | Bullet' 
+            { _ptPos :: Point2
+            , _ptVel :: Point2
+            , _ptPict :: Drawing
+            , _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 Either3 a b c = E3x1 a | E3x2 b | E3x3 c
+
+data Smoke = 
+    Smoke
+        { _smPos    :: Point2
+        , _smRad    :: Float
+        , _smColor  :: Color
+        , _smUpdate :: Smoke -> Maybe Smoke
+        , _smPs     :: [Point2]
+        , _smTime   :: Int
+        }
+
+data WLID = WLID { _wlIDx :: Int, _wlIDy :: Int, _wlIDid :: Int}
+
+data Wall = Wall 
+                { _wlLine :: [Point2] , _wlID :: Int 
+                , _wlColor :: Color
+                , _wlDraw :: Maybe (Wall -> Drawing)
+                , _wlSeen :: Bool
+                , _wlIsSeeThrough :: Bool
+--                , _wlID' :: WLID
+                }
+          | BlockAutoDoor 
+                { _wlLine :: [Point2] 
+                , _wlID :: Int 
+                , _doorMech :: World -> World
+                , _wlColor :: Color
+                , _wlDraw :: Maybe (Wall -> Drawing)
+                , _wlSeen :: Bool
+                , _blIDs :: [Int]
+                , _blHP :: Int
+                , _wlIsSeeThrough :: Bool
+--                , _wlID' :: WLID
+                }
+          | AutoDoor 
+                { _wlLine :: [Point2] , _wlID :: Int 
+                , _doorMech :: World -> World
+                , _wlColor :: Color
+                , _wlDraw :: Maybe (Wall -> Drawing)
+                , _wlSeen :: Bool
+                , _wlIsSeeThrough :: Bool
+--                , _wlID' :: WLID
+--                , _doorLine :: [Point2]
+                }
+          | Door 
+                { _wlLine :: [Point2] , _wlID :: Int 
+                , _doorMech :: World -> World
+                , _wlColor :: Color
+                , _wlDraw :: Maybe (Wall -> Drawing)
+                , _wlSeen :: Bool
+                , _wlIsSeeThrough :: Bool
+--                , _wlID' :: WLID
+--                , _doorLine :: [Point2]
+                }
+          | Block 
+                { _wlLine :: [Point2]
+                , _wlID :: Int
+                , _wlColor :: Color
+                , _wlDraw :: Maybe (Wall -> Drawing)
+                , _wlSeen :: Bool
+                , _blIDs :: [Int]
+                , _blHP :: Int
+                , _wlIsSeeThrough :: Bool
+                , _blVisible :: Bool
+                , _blShadows :: [Int]
+                , _blDegrades :: [Int]
+--                , _wlID' :: WLID
+                }
+
+data Block' = Block'
+    { _blPoly  :: [Point2]
+    , _blLines :: [[Point2]]
+    , _blColor :: Color
+    , _blSeen  :: Bool
+    , _blHP'   :: [Int]
+    , _blVisible' :: Bool
+    , _blShadows' :: [Int]
+    , _blID :: 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 Ammo = PistolBullet | LiquidFuel | Battery | Shell
+    deriving (Eq,Ord,Enum)
+
+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
+    deriving (Eq,Ord,Show)
+
+type Poly = [Point2]
+data PSType = PutCrit Creature
+            | PutLS LightSource Drawing
+            | PutButton Button
+            | PutFlIt FloorItem
+            | PutPressPlate PressPlate
+            | PutAutoDoor Point2 Point2
+            | PutBlock [Int] Color [Point2]
+            | PutWindowBlock 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 ''Particle
+makeLenses ''Particle'
+makeLenses ''Wall
+makeLenses ''Smoke
+makeLenses ''ForceField
+makeLenses ''FFState
+makeLenses ''PressPlate
+makeLenses ''Button
+makeLenses ''PSType
+makeLenses ''PlacementSpot
+makeLenses ''Room
+makeLenses ''Sound
+--
+-- }}}
+
+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/Debug.hs

@@ -0,0 +1,50 @@
+module Dodge.Debug where
+
+import Dodge.Data
+import Dodge.Base
+
+import Geometry.Data
+import Picture
+
+import Control.Lens
+
+
+import qualified Data.IntMap.Strict as IM
+
+drawCircleAtFor :: Point2 -> Int -> World -> World
+drawCircleAtFor p t w = 
+   let n = newParticleKey w
+   in  over particles ( IM.insert n
+            Particle { _ptPos = p
+                     , _ptStartPos = p
+                     , _ptVel = (0,0)
+                     , _ptPict = onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20
+                     , _ptID = n
+                     , _ptUpdate = ptTimer t n
+                     } ) w
+drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
+drawCircleAtForCol p t col w = 
+   let n = newParticleKey w
+   in  over particles ( IM.insert n
+            Particle { _ptPos = p
+                     , _ptStartPos = p
+                     , _ptVel = (0,0)
+                     , _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20
+                     , _ptID = n
+                     , _ptUpdate = ptTimer t n
+                     } ) w
+drawLineForCol :: [Point2] -> Int -> Color -> World -> World
+drawLineForCol ps t col w = 
+   let n = newParticleKey w
+   in  over particles ( IM.insert n
+            Particle { _ptPos = head ps
+                     , _ptStartPos = head ps
+                     , _ptVel = (0,0)
+                     , _ptPict = onLayer PtLayer $ color col $ lineOfThickness 5 ps
+                     , _ptID = n
+                     , _ptUpdate = ptTimer t n
+                     } ) w
+
+ptTimer :: Int -> Int -> World -> World
+ptTimer 0    i = over particles (IM.delete i)
+ptTimer time i = set (particles . ix i . ptUpdate) $ ptTimer (time - 1) i

src/Dodge/Initialisation.hs

@@ -0,0 +1,68 @@
+module Dodge.Initialisation where
+-- imports {{{
+import Dodge.Prototypes
+import Dodge.Data
+import Dodge.Critters
+import Dodge.Base
+
+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 Graphics.Gloss
+--import Graphics.Gloss.Interface.IO.Game
+--import Graphics.Gloss.Geometry.Angle
+--import Graphics.Gloss.Geometry.Line
+--import qualified Graphics.Gloss.Data.Point.Arithmetic as PA
+--import Graphics.Gloss.Data.Vector
+--import Graphics.Gloss.Data.Point
+import Foreign.ForeignPtr
+import Control.Concurrent
+import Data.Tree
+
+initializeWorld :: World -> World
+initializeWorld w = w
+
+initialWorld = basicWorld
+                { _keys = S.empty
+                , _cameraPos = (0,0)
+                , _cameraRot = 0
+                , _cameraZoom = 1
+                , _creatures = IM.fromList [(0,startCr)]
+                , _particles = IM.empty
+                , _walls = IM.empty
+                , _forceFields = IM.empty
+                , _floorItems = IM.empty
+                , _randGen = mkStdGen 2
+                , _mousePos = (0,0)
+                , _testString = []
+                , _yourID = 0
+                , _worldEvents = id
+                , _pressPlates = IM.empty
+                , _buttons = IM.empty
+                , _soundQueue = []
+--                , _loadedSounds = IM.empty
+                , _sounds = M.empty
+                , _decorations = IM.empty
+                , _unlimitedAmmo = True
+                , _storedLevel = Nothing
+                , _menuState = LevelMenu 1
+                , _worldState = M.empty
+                , _windowX = 800
+                , _windowY = 840
+                }
+
+

src/Dodge/KeyEvents.hs

@@ -0,0 +1,190 @@
+module Dodge.KeyEvents where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Dodge.CreatureActions
+import Dodge.SoundLogic
+
+import Geometry
+
+import Control.Lens
+
+import Data.Maybe
+import Data.Char
+import Data.List
+import Data.Function
+
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+
+import SDL
+
+--import Graphics.Gloss
+--import Graphics.Gloss.Interface.IO.Game
+
+-- }}}
+
+pauseGame :: World -> World
+pauseGame w = w {_menuState = PauseMenu}
+
+handleEvent :: World -> Event -> Maybe World
+handleEvent w e = case eventPayload e of
+    KeyboardEvent kev -> handleKeyEvent w kev
+    MouseMotionEvent mmev -> handleMouseMotionEvent w mmev
+    MouseButtonEvent mbev -> handleMouseButtonEvent w mbev
+    MouseWheelEvent mwev -> handleMouseWheelEvent w mwev
+    WindowSizeChangedEvent sev -> handleResizeEvent w sev
+    _ -> Just w
+
+handleKeyEvent :: World -> KeyboardEventData -> Maybe World
+handleKeyEvent w kev = case keyboardEventKeyMotion kev of
+    Released -> Just $ over keys (S.delete $ getKeycode kev) w
+    _  -> handlePressedKeyEvent (addKey (getKeycode kev) w) (keyboardEventRepeat kev) (getKeycode kev)
+    where getKeycode :: KeyboardEventData -> Keycode
+          getKeycode = keysymKeycode . keyboardEventKeysym
+
+addKey :: Keycode -> World -> World
+addKey k = over keys $ S.insert k
+
+handlePressedKeyEvent :: World -> Bool -> Keycode -> Maybe World
+handlePressedKeyEvent w True _ = Just w
+handlePressedKeyEvent w _    keycode
+    = case keycode of
+        KeycodeEscape -> Nothing
+--        KeycodeEscape -> Just $ pauseGame $ escapeMap w
+        KeycodeC      -> Just $ pauseGame $ escapeMap w
+        KeycodeF      -> Just $ dropItem w
+        KeycodeM      -> Just $ toggleMap w
+        KeycodeP      -> Just $ pauseGame $ escapeMap w
+        KeycodeR      -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w
+        KeycodeT      -> Just $ testEvent w
+        KeycodeSpace  -> Just $ spaceAction w
+        KeycodeQ      -> Just $ w {_cameraRot = _cameraRot w + 0.01}
+        KeycodeE      -> Just $ w {_cameraRot = _cameraRot w - 0.01}
+        _ -> Just w
+
+handleMouseMotionEvent :: World -> MouseMotionEventData -> Maybe World
+handleMouseMotionEvent w mmev 
+    = Just $ set mousePos (fromIntegral x - 0.5*_windowX w
+                          ,0.5*_windowY w - fromIntegral y
+                          ) w
+    where P (V2 x y) = mouseMotionEventPos mmev
+
+handleMouseButtonEvent :: World -> MouseButtonEventData -> Maybe World
+handleMouseButtonEvent w mbev = case mouseButtonEventMotion mbev of
+    Released -> Just $ over mouseButtons (S.delete but) w
+    Pressed  -> handlePressedMouseButton but $ over mouseButtons (S.insert but) w
+    where but = mouseButtonEventButton mbev
+
+handlePressedMouseButton :: MouseButton -> World -> Maybe World
+handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos w) w
+handlePressedMouseButton _ w = Just w
+
+handleMouseWheelEvent :: World -> MouseWheelEventData -> Maybe World
+handleMouseWheelEvent w mwev = 
+    case mouseWheelEventPos mwev of
+        V2 x y | y > 0 -> Just $ wheelUpEvent w
+               | y < 0 -> Just $ wheelDownEvent w
+               | otherwise -> Just $ w
+--        case mouseWheelEventDirection mwev of
+--    ScrollNormal  -> Just $ wheelUpEvent w
+--    ScrollFlipped -> Just $ wheelDownEvent w
+
+
+handleResizeEvent :: World -> WindowSizeChangedEventData -> Maybe World
+handleResizeEvent w sev = Just $ set windowX (fromIntegral x)
+                               $ set windowY (fromIntegral y) w
+    where V2 x y = windowSizeChangedEventSize sev
+
+toggleMap w = w & mapDisplay . _1 %~ not
+escapeMap w = w & mapDisplay . _1 .~ False
+
+wheelUpEvent :: World -> World
+wheelUpEvent w 
+    = case _mapDisplay w of
+        (True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z))
+        _ | rbPressed -> fromMaybe w $ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w))
+                                                                  <*> pure w
+          | lbPressed -> w {_cameraZoom = _cameraZoom w + 0.1}
+          | otherwise -> upInvPos w
+    where lbPressed = ButtonLeft `S.member` mbs
+          rbPressed = ButtonRight `S.member` mbs
+          mbs = _mouseButtons w
+wheelDownEvent :: World -> World
+wheelDownEvent w 
+    = case _mapDisplay w of
+        (True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z))
+        _ | rbPressed ->  fromMaybe w $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w))
+                                                                     <*> pure w
+          | lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
+          | otherwise -> downInvPos w
+    where lbPressed = ButtonLeft `S.member` mbs
+          rbPressed = ButtonRight `S.member` mbs
+          mbs = _mouseButtons w
+
+upInvPos :: World -> World
+--upInvPos w = soundOnce 3 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
+upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
+    where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w
+          isis = is ++ is
+          x = before (_crInvSel (you w)) isis
+downInvPos :: World -> World
+--downInvPos w = playSoundFromFor InventorySound 3 2 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
+downInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
+    where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w
+          isis = is ++ is
+          x = after (_crInvSel (you w)) isis
+
+
+-- these are incomplete: should put in error case here!
+before y (x:z:ys) | y == z    = x
+                  | otherwise = before y (z:ys)
+after y (x:z:ys)  | y == x    = z
+                  | otherwise = after y (z:ys)
+
+mouseActionsCr :: S.Set MouseButton -> Creature -> Creature
+mouseActionsCr keys cr 
+    | rbPressed 
+        = set ( crState . stance . posture) Aiming cr
+    | otherwise
+        = set ( crState . stance . posture) AtEase cr
+    where lbPressed = ButtonLeft `S.member` keys
+          rbPressed = ButtonRight `S.member` keys
+--          wUp       = MouseButton WheelUp `S.member` keys
+--         -- wUp       = Char 'q' `S.member` keys
+--          wDown     = MouseButton WheelDown `S.member` keys
+
+mouseActionsWorld :: S.Set MouseButton -> World -> World
+mouseActionsWorld keys w 
+    | lbPressed && rbPressed 
+        = useItemContinuous (_yourID w) w
+    | mbPressed 
+        = set lbClickMousePos (_mousePos w) $ over cameraRot (\r-> r - rotation) w
+    | otherwise
+        = w
+    where lbPressed = ButtonLeft `S.member` keys
+          rbPressed = ButtonRight `S.member` keys
+          mbPressed = ButtonMiddle `S.member` keys
+          ---wUp       = MouseButton WheelUp `S.member` keys
+          ---wDown     = MouseButton WheelDown `S.member` keys
+          ---theItem   = _crInv (you w) IM.! _crInvSel (you w)
+          rotation  = angleBetween (_mousePos w) (_lbClickMousePos w)
+
+-- for now, left are floor items, right are buttons
+closestActiveObject :: World -> Maybe (Either FloorItem Button)
+closestActiveObject w = listToMaybe $ sortBy (compare `on` dist ypos . pos) $ actObjs
+    where ypos = _crPos $ you w
+          actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w) 
+                        $ map Left (IM.elems $ _floorItems w) ++ map Right (IM.elems $ _buttons w)
+          pos (Right x) = _btPos x
+          pos (Left x)  = _flItPos x
+
+spaceAction :: World -> World
+spaceAction w = case closestActiveObject w of
+    Just (Left flit) -> pickUpItem' flit w
+    Just (Right but) -> _btEvent but but w
+    Nothing -> w
+
+testEvent :: World -> World
+testEvent w = w
+

src/Dodge/Layout.hs

@@ -0,0 +1,187 @@
+module Dodge.Layout where
+-- imports {{{
+import Dodge.Data
+import Dodge.Weapons
+import Dodge.Critters
+import Dodge.LevelGen
+import Dodge.Base
+import Dodge.RandomHelp
+import Dodge.Prototypes
+import Dodge.Path
+
+import Geometry
+--
+--import Graphics.Gloss
+--import Graphics.Gloss.Data.Vector
+--import Graphics.Gloss.Geometry.Line
+--import Graphics.Gloss.Geometry.Angle
+--
+import Control.Monad.State
+--import Control.Monad.Loops
+import Control.Lens
+import System.Random
+
+import Data.List
+import Data.Maybe
+import Data.Tree
+import Data.Either
+import Data.Function
+import qualified Data.Map as M
+
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.Basic
+import Data.Graph.Inductive.PatriciaTree
+import Data.Graph.Inductive.NodeMap
+
+import qualified Data.IntMap.Strict as IM
+-- }}}
+
+generateFromTree :: State StdGen (Tree Room) -> World -> World
+generateFromTree t w = zoning $ placeSpots plmnts 
+            $ w {_walls = wallsFromTree tr, _randGen = g
+--                           ,_loadedSounds = lSounds
+                           ,_pathGraph = path
+                           ,_pathGraph' = pairGraph
+                           ,_pathPoints = foldr insertPoint IM.empty (labNodes path) 
+                           ,_pathInc = pinc}
+    where tr = evalState t $ _randGen w
+          plmnts = concatMap _rmPS $ flatten tr
+          g = _randGen w
+--          lSounds = _loadedSounds w
+          path = pairsToGraph dist pairGraph
+          pairGraph = makePath tr
+          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+          pinc = M.fromList $ pairsToIncidence pairGraph
+          zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
+                        w
+          wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
+                            = insertIMInZone x y wlid wl
+                        | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
+            where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
+                  wlid  = _wlID wl
+                  ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
+
+makePath :: Tree Room -> [(Point2,Point2)]
+makePath = concat . map _rmPath . flatten
+
+wallsFromTree :: Tree Room -> IM.IntMap Wall
+wallsFromTree t = divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
+
+divideWall :: Wall -> [Wall]
+divideWall wl
+    = let (a:b:_) = _wlLine wl
+          --ps = divideLine (zoneSize * 2) a b
+          ps = divideLine (zoneSize * 2) a b
+      in  map (\(x,y) -> wl {_wlLine = [x,y]}) $ zip (init ps) (tail ps)
+
+divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
+divideWallIn wl wls = 
+    let (wl':newWls) = divideWall wl
+        k = newKey wls
+        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
+    in  foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls')
+
+divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
+divideWalls wls = IM.foldr divideWallIn wls wls
+         
+collapseTree :: Tree (Tree (Either Room Room)) -> Tree (Either Room Room)
+collapseTree = g . expandTreeBy f
+    where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
+          f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
+          g (Node (Right x) []) = Node (Right x) []
+          g (Node (Right x) xs) = Node (Left x) $ map g xs
+          g (Node y ys) = Node y $ map g ys
+
+
+insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
+insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
+    where f _ = IM.insert y obj
+
+allPairs :: Eq a => [a] -> [(a,a)]
+allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
+
+treePost :: [a] -> a -> Tree a
+treePost []     y = Node y []
+treePost (x:xs) y = Node x [treePost xs y]
+
+randomiseLinks :: RandomGen g => Room -> State g (Tree (Either Room Room))
+randomiseLinks r = do
+    newLinks <- shuffle $ init $ _rmLinks r
+    return $ connectRoom $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
+randLinks :: RandomGen g => Room -> State g Room
+randLinks r = do
+    newLinks <- shuffle $ init $ _rmLinks r
+    return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
+
+filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
+filterLinks cond r = do
+    newLinks <- shuffle $ filter cond $ init $ _rmLinks r
+    return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
+
+changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
+changeLinkTo cond r = do
+    l <- takeOne $ filter cond $ _rmLinks r
+    let newLinks = delete l (_rmLinks r) ++ [l]
+    return $ r {_rmLinks = newLinks}
+
+
+-- Left elements get new children, Right elements inherit the children from the
+-- mapped over node
+composeTreeWith :: (a -> Tree (Either b b)) -> Tree a -> Tree (Either b b)
+composeTreeWith f (Node x []) = f x
+composeTreeWith f (Node x xs) = paste xs $ f x
+    where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs)
+          paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys)
+
+doPolysIntersect :: [Point2] -> [Point2] -> Bool
+doPolysIntersect (p:ps) (q:qs)
+    = any isJust $ (\(a,b) (c,d) -> intersectSegSeg' a b c d) <$> pair1s <*> pair2s
+    where pair1s = zip (p:ps) (ps++[p])
+          pair2s = zip (q:qs) (qs++[q])
+doPolysIntersect [] _  = False
+doPolysIntersect _  [] = False
+
+boundClip :: Tree Room -> Bool
+boundClip t = or $ map (uncurry doPolysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
+                    ++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs]
+    where xs = map _rmBound $ flatten t
+          f ([],qs) = False
+          f ((p:_),qs) = pointInPolygon p qs
+
+noBoundClip :: Tree Room -> Bool
+noBoundClip = not . boundClip
+
+connectRoom :: a -> Tree (Either a a)
+connectRoom r = Node (Right r) [] 
+deadRoom :: a -> Tree (Either a a)
+deadRoom r = Node (Left r) []
+
+onRoot :: (a -> a) -> Tree a -> Tree a
+onRoot f (Node t ts) = Node (f t) ts
+
+shiftRoomTree :: Tree Room -> Tree Room
+shiftRoomTree (Node t []) = Node t []
+shiftRoomTree (Node t ts) = Node t $ zipWith (\l -> shiftRoomTree . onRoot (shiftRoomBy l . f)) 
+                                             (_rmLinks t) 
+                                             ts
+    where f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a)  r
+                where (p,a) = last $ _rmLinks r
+
+shiftRoomBy :: (Point2,Float) -> Room -> Room
+shiftRoomBy shift@(pos,rot) r = 
+   over rmPolys (fmap (map (shiftPointBy shift)))
+   $ over rmLinks (fmap (shiftLinkBy shift))
+   $ over rmPath (map (shiftPathPointBy shift))
+   $ over rmPS (fmap (shiftPSBy shift))
+   $ over rmBound (map (shiftPointBy shift))
+   r
+
+shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
+
+shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
+shiftPSBy (pos,rot) ps = case ps of
+    PS {} -> over psPos (shiftPointBy (pos,rot))
+                            $ over psRot (+rot)
+                            ps
+
+

src/Dodge/LevelGen.hs

@@ -0,0 +1,756 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Dodge.LevelGen where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+import Dodge.Prototypes
+import Dodge.Block
+
+import Geometry
+import Picture
+
+import System.Random
+--import Graphics.Gloss
+--import Graphics.Gloss.Geometry.Line
+--import Graphics.Gloss.Geometry.Angle
+--import Graphics.Gloss.Data.Vector
+import Control.Monad.State
+import Data.List
+import Data.Function
+import Control.Applicative
+import Control.Lens
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+import Data.Graph.Inductive
+import Data.Graph.Inductive.NodeMap
+import Data.Tree
+-- }}}
+
+inSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
+    where p1' = p1 +.+ normalizeV (p1 -.- p2)
+          p2' = p2 +.+ normalizeV (p2 -.- p1)
+          a1' = a1 +.+ normalizeV (a1 -.- a2)
+          a2' = a2 +.+ normalizeV (a2 -.- a1)
+
+--
+
+
+--supposes that the quadrilateral points are given in anticlockwise order
+-- cutOutQuad :: Point -> Point -> Point -> Point -> IM.IntMap Wall -> IM.IntMap Wall
+-- cutOutQuad p1 p2 p3 p4 walls = cutLine p4 p1 . cutLine p3 p4 . cutLine p2 p3 . cutLine p1 p2 $ walls
+
+collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+collidePointAllWalls p1 p2 walls = IM.filter f walls
+    where f wall
+            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+                of Nothing -> False
+                   _       -> True
+
+-- returns walls that collide with lines, and the point of collision
+
+collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
+collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
+    where f wall
+            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+                of Nothing -> Nothing
+                   Just p  -> Just (wall,p)
+
+collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
+collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls
+    where f wall
+            = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) 
+                of Nothing -> Nothing
+                   Just p  -> Just (wall,[p])
+
+collidePolygonWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
+collidePolygonWalls (p:ps) walls 
+    = IM.unionsWith f (fmap g (zip (p:ps) (ps ++ [p])))
+    -- = fmap ($ walls) $ zipWith collidePointAllWallsPoints' (init ps) (tail ps)
+        --where f (x,xs) (_,ys) = (x,xs++ys)
+        where f (x,xs) (_,ys) = (x,xs++ys)
+              g (p1,p2) = collidePointAllWallsPoints' p1 p2 walls
+
+-- -- assumes that walls meet in corners
+-- there appears to be an issue when one wall point is inside and the other exactly on the polygon
+-- this is probably an issue with collidePolygonwalls
+existingWallChanges :: [Point2] -> (Wall,[Point2]) -> [Wall]
+existingWallChanges poly (wall,ps) = catMaybes [w1,w2]
+     where wp1 = _wlLine wall !! 0
+           wp2 = _wlLine wall !! 1
+           c1  = head $ sortBy (compare `on` dist wp1) ps
+           c2  = head $ sortBy (compare `on` dist wp2) ps
+           --c1  = last ps
+           --c2  = last ps
+           w1 = if errorPointInPolygon 5 wp1 poly || wp1 == c1
+                    then Nothing
+                    else Just $ wall {_wlLine = [ wp1, c1 ] }
+           w2 = if errorPointInPolygon 6 wp2 poly || wp2 == c2
+                    then Nothing
+                    else Just $ wall {_wlLine = [ c2, wp2 ] }
+
+
+removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+removeWallsInPolygon ps walls = IM.filter (not . cond) walls
+--    where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
+--                        && pointInsidePolygon (_wlLine wall !! 1) ps
+    where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
+                        && pointInsidePolygon (_wlLine wall !! 1) ps
+
+pointInsidePolygon :: Point2 -> [Point2] -> Bool
+pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
+                                || any (\l -> uncurry isOnLine l p) pairs
+    where pairs = zip (x:xs) (xs ++ [x])
+          s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
+                -.- p
+
+
+-- ok, now to find out which new walls need to be drawn
+drawCutWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall
+drawCutWall (p1,p2) walls = 
+    case maybeW of Just w -> if errorIsLHS 200 (_wlLine w !! 0) (_wlLine w !! 1) p3
+                                 then walls
+                                 else IM.insert k newWall walls
+                   Nothing -> IM.insert k newWall walls
+    where p3 = 0.5 *.* (p1 +.+ p2)
+          p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
+          maybeW = wallOnLine p3 p4 walls
+          k = case IM.lookupMax walls
+                of Nothing    -> 0
+                   Just (j,_) -> j + 1
+          newWall = basicWall {_wlLine = [p1,p2], _wlID = k}
+          
+
+drawCutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+drawCutWalls (q:qs) walls = foldr drawCutWall walls (zip (q:qs) (qs++[q]))
+--    where (q:qs) = reverse $ orderPolygon
+--                    -- $ intersectPolygonWalls ps walls
+--                    $ maybeToList $ intersectSegSeg (20,0) (100,900) (-200,400) (200,400)
+--                     -- $ (++) ps $ nub $ concat $ IM.elems $ fmap snd $ collidePolygonWalls ps walls
+
+-- I have no idea why collidePolygonWalls is sometimes dropping an intersection
+-- point between the walls and the polygon
+-- Trying a workaround
+intersectPolygonWalls :: [Point2] -> IM.IntMap Wall -> [Point2]
+intersectPolygonWalls ps walls = nub $ concat $ IM.elems $ IM.map (intersectSegsWall ps) walls
+--intersectPolygonWalls (p:ps) walls = nub $ concat [intersectSegWalls s1 s2 walls | (s1,s2) <- segs]
+--    where segs = zip (p:ps) (ps ++ [p])
+
+intersectSegWalls s1 s2 ws = concatMap (intersectSegWall s1 s2) $ IM.elems ws
+
+intersectSegsWall (p:ps) wall = concat [intersectSegWall s1 s2 wall | (s1,s2) <- zip (p:ps) (ps++[p])]
+
+-- finds intersection, or any segment points contained in the wall
+intersectSegWall s1 s2 w = catMaybes [myIntersectSegSeg s1 s2 w1 w2
+--                                     ,intersectSegPoint w1 w2 s1
+--                                     ,intersectSegPoint w1 w2 s2
+                                     ]
+    where w1 = _wlLine w !! 0
+          w2 = _wlLine w !! 1
+
+intersectSegPoint s1 s2 p = if isOnLine s1 s2 p then Just p else Nothing
+
+-- new procedure: line by line
+-- then remove all walls inside the polygon
+
+-- abuses the list nature of wlLine
+cutWall1 :: Point2 -> Point2 -> Wall -> Wall
+cutWall1 p1 p2 wall = case maybeCP of
+                            Nothing -> wall
+                            Just cp -> wall {_wlLine = [cp,w0,w1]}
+    where wl = _wlLine wall
+          w0 = wl !! 0
+          w1 = wl !! 1
+          w0' = w0 +.+ normalizeV (w0 -.- w1)
+          w1' = w1 +.+ normalizeV (w1 -.- w0)
+          p1' = p1 +.+ normalizeV (p1 -.- p2)
+          p2' = p2 +.+ normalizeV (p2 -.- p1)
+          pT  = p1' +.+ vNormal (normalizeV (p1 -.- p2))
+          pB  = p1' -.- vNormal (normalizeV (p1 -.- p2))
+          --maybeCP = intersectSegSeg p1' p2' w0' w1'--  <|> intersectSegSeg w0 w1 pT pB
+          --maybeCP = inSegSeg p1 p2 w0 w1--  <|> intersectSegSeg w0 w1 pT pB
+          maybeCP = inSegSeg p1 p2 w0 w1--  <|> intersectSegSeg w0 w1 pT pB
+          --maybeCP = intersectSegSeg p1 p2 w0 w1--  <|> intersectSegSeg w0 w1 pT pB
+cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+cutWalls1 p1 p2 ws = foldr splitAndAdd ws $ IM.map (cutWall1 p1 p2) ws
+    where splitAndAdd w ws 
+            = case _wlLine w of
+                (cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1]
+                                                          ,_wlID = newKey ws})
+                                    $ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws
+                (x:y:[]) -> ws
+
+cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2]
+cutWallsPoints p1 p2 ws = map head $ filter (\xs -> length xs > 2) 
+                                $ IM.elems $ IM.map (_wlLine . cutWall1 p1 p2) ws
+
+cutWallsProcess :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall)
+cutWallsProcess (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
+    where f (p1,p2) (as,ws') = (as ++ cutWallsPoints p1 p2 ws', cutWalls1 p1 p2 ws')
+
+cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+cutWalls qs walls = -- IM.filter (not . wallIsZeroLength) $ fuseWalls $ 
+                    drawCutWalls rs  $ IM.filter (not.wallIsZeroLength) 
+                                        $ removeWallsInPolygon ps -- cwals
+                                                                  (fuseWallsWith zs cwals)
+    where (zs,cwals) = cutWallsProcess ps walls
+          ps = orderPolygon qs
+          --ps = orderPolygon $ map perturbToWallPoints qs
+          rs = orderPolygon $ nub $ zs ++ qs
+--          perturbToWallPoints p = fromMaybe p $ find (\p1 -> dist p p1 < 1) wps
+
+
+fusePoint :: [Point2] -> Point2 -> Maybe Point2
+fusePoint ps p = find (\q -> dist p q < 5) ps
+
+pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2
+pointIfNotClose ps p = case fusePoint ps p of
+                        Nothing -> Just p
+                        _       -> Nothing
+
+fuseWall :: ([Point2], Wall) -> ([Point2], Wall)
+fuseWall (ps, w) = (qs, w {_wlLine = newLine})
+    where wp0 = _wlLine w !! 0
+          wp0' = fromMaybe wp0 $ fusePoint ps wp0
+          ps0 = maybeToList (pointIfNotClose ps wp0) ++ ps
+          wp1 = _wlLine w !! 1
+          wp1' = fromMaybe wp1 $ fusePoint ps0 wp1
+          newLine = [wp0',wp1']
+          qs   = catMaybes [pointIfNotClose ps wp0, pointIfNotClose ps0 wp1] ++ ps
+
+fuseWalls :: IM.IntMap Wall -> IM.IntMap Wall
+fuseWalls ws = snd $ IM.foldr fuseWalls' ([], IM.empty) ws
+    where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
+                                  in  (qs, IM.insert (_wlID w') w' ws)
+fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws
+    where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
+                                  in  (qs, IM.insert (_wlID w') w' ws)
+
+wallIsZeroLength w = l !! 0 == l !! 1
+    where l = _wlLine w
+
+treeTrunk :: [a] -> Tree a -> Tree a
+treeTrunk [] t     = t
+treeTrunk (x:xs) t = Node x [treeTrunk xs t]
+
+applyToRoot :: (a -> a) -> Tree a -> Tree a
+applyToRoot f (Node x xs) = Node (f x) xs
+
+placeSpots :: [PlacementSpot] -> World -> World
+placeSpots pss w = foldr placeSpot w basicPlacements
+    where (collectivePlacements,basicPlacements) = partition typeIsCollective pss
+          typeIsCollective (ps@PS {}) = case _psType ps of CollectivePS {} -> True
+                                                           _               -> False
+          typeIsCollective _ = False
+          
+          groupedPlacements = groupBy ((==) `on` _collectiveID . _psType) 
+                                $ sortBy (compare `on` _collectiveID . _psType) collectivePlacements
+
+placeSpot :: PlacementSpot -> World -> World
+placeSpot ps w = case ps of
+    PS {_psPos = p, _psRot = rot, _psType = PutButton bt} 
+        -> placeBt bt p rot w
+    PS {_psPos = p, _psRot = rot, _psType = PutFlIt fi} 
+        -> placeFlIt fi p rot w
+    PS {_psPos = p, _psRot = rot, _psType = PutCrit cr} 
+        -> placeCr cr p rot w
+    PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec} 
+        -> placeLS ls dec p rot w
+    PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp} 
+        -> placePressPlate pp p rot w
+    PS {_psType = RandPS rgen} 
+        -> placeSpot (set psType evaluatedType ps) (set randGen g w)
+        where (evaluatedType, g) = runState rgen (_randGen w)
+
+    PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b} 
+        -> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+
+    PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b} 
+        -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+
+    PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps} 
+        -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
+
+    PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b} 
+        -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
+                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+    PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b} 
+        -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) 
+                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+
+    PS {_psPos = p, _psRot = rot, _psType = PutWindowBlock a b}
+        -> putWindowBlock (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+
+    PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
+        -> rmCrossPaths $ over walls (addWindow (q:qs) c) w
+                where (q:qs) = translateS p $ rotateS rot ps
+                      rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
+
+    _   -> w
+
+class Shiftable a where
+    translateS :: Point2 -> a -> a
+    rotateS    :: Float -> a -> a
+
+instance {-# OVERLAPPING #-} Shiftable Point2 where
+    translateS = (+.+)
+    rotateS    = rotateV
+
+instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
+    translateS p (x,y) = (translateS p x,translateS p y)
+    rotateS    r (x,y) = (   rotateS r x,   rotateS r y)
+
+instance (Shiftable a) => Shiftable [a] where
+    translateS p x = map (translateS p) x
+    rotateS    r x = map (rotateS r)    x
+
+instance Shiftable RoomLink where
+    translateS q (RL p r) = RL (p +.+ q) r
+    rotateS    s (RL p r) = RL (rotateV s p) (r+s)
+
+instance Shiftable PlacementSpot where
+    translateS p' (PS p r x) = PS (p +.+ p') r x
+    rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x
+
+pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
+pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs)
+                           pairs' = map (\(x,y)->(x,y,f x y)) pairs
+                       in  undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs'
+
+makeButton :: Color -> (World -> World) -> Button
+makeButton c eff = Button
+    { _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
+    , _btPos = (0,0)
+    , _btRot = 0
+    , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
+--                                . set (buttons . ix (_btID b) . btPict) 
+--                                      (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
+--                                . set (buttons . ix (_btID b) . btState) BtNoLabel
+--                                . set (buttons . ix (_btID b) . btEvent) (\b -> return)
+                                . soundOnce 1 $ w
+    , _btID = 0
+    , _btText = "Button"
+    --, _btText = "Button"
+    , _btState = BtOff
+    }
+    where
+        turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
+        onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
+
+makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
+makeSwitch c effOn effOff = Button
+    { _btPict = offPict
+    , _btPos = (0,0)
+    , _btRot = 0
+    , _btEvent = flipSwitch
+    , _btID = 0
+    , _btText = "Switch"
+    , _btState = BtOff
+    }
+    where 
+        flipSwitch b w = switchEffect b . soundOnce 1 $ w
+        switchEffect b = case _btState b of
+                            BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
+                            BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
+        offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
+                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
+                                  ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
+                                 ]
+        onPict  = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
+                                  polygon $ rectNSEW (-2) (-5) (-10) (10)
+                                  ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
+                                 ]
+        turnOn :: Button -> Button
+        turnOn bt = bt {_btState = BtOn, _btPict = onPict}
+        turnOff :: Button -> Button
+        turnOff bt = bt {_btState = BtOff, _btPict = offPict}
+          
+
+
+-- probably don't have to rebuild the entire graph, oh well
+addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
+addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) 
+                                $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+                                $ set pathGraph newGraph
+                                $ set pathGraph' newGraphPairs
+                                $ addTriggerDoor c cond a b w
+    where bid = newKey $ _buttons w
+          cond w = BtNoLabel == (_btState $ _buttons w IM.! bid)
+          bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
+          (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) 
+                                                   $ _pathGraph' w
+          newGraph = pairsToGraph dist newGraphPairs
+          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+          eff w' = over pathGraph' (removedPairs ++) 
+                   . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
+          f (x,y) = (x,y,dist x y)
+
+addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
+addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) 
+                                $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+                                $ set pathGraph newGraph
+                                $ set pathGraph' newGraphPairs
+                                $ addTriggerDoor c cond a b w
+    where bid = newKey $ _buttons w
+          cond w = BtOn == (_btState $ _buttons w IM.! bid)
+          bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
+          (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) 
+                                                   $ _pathGraph' w
+          newGraph = pairsToGraph dist newGraphPairs
+          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+          openDoor w' = over pathGraph' (removedPairs ++) 
+                        . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
+          f (x,y) = (x,y,dist x y)
+          closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs)
+                        . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
+
+addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
+addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
+
+triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
+    where i = newKey wls
+          is = [i..]
+
+mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
+mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
+                               xs
+                               [ [pld,hwd]
+                               , [hwd,hwu]
+                               , [hwu,plu]
+                               , [plu,pld]
+                               , [pru,hwu]
+                               , [hwu,hwd]
+                               , [hwd,prd]
+                               , [prd,pru]
+                               ]
+                               [ [plld,pld]
+                               , [pld,plu]
+                               , [plu,pllu]
+                               , [pllu,plld]
+                               , [prru,pru]
+                               , [pru,prd]
+                               , [prd,prrd]
+                               , [prrd,prru]
+                               ]
+    where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
+          hw = 0.5 *.* (pl +.+ pr)
+          perp = 20 *.* normalizeV (pl -.- pr)
+          --perp = pl -.- hw
+          plu = pl +.+ norm
+          pld = pl -.- norm
+          pru = pr +.+ norm
+          prd = pr -.- norm
+          hwu = hw +.+ norm
+          hwd = hw -.- norm
+          pllu = plu +.+ perp
+          plld = pld +.+ perp
+          prru = pru -.- perp
+          prrd = prd -.- perp
+          addSound (x:xs) = f x : xs
+          f wl = over doorMech g wl
+          g dm w | dist wp pld > 2 && dist wp hwd > 2 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
+                                                                    $ dm w
+                 | otherwise = dm w
+            where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
+
+triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
+triggerDoorPane c cond n [a,b] [a',b'] = Door
+    { _wlLine = [a,b]
+    , _wlID = n
+    , _doorMech = dm
+    , _wlColor = c
+    , _wlDraw = Nothing
+    , _wlSeen = False
+    , _wlIsSeeThrough = False
+--    , _doorLine = [a,b,a',b']
+    }
+    where 
+        dm w | cond w    = flip (foldr changeZonedWall) zoneps
+                           $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
+             | otherwise = flip (foldr changeZonedWall') zoneps
+                           $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
+        zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
+               | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
+        openDoor :: Wall -> Wall
+        openDoor wl = case _wlLine wl of
+                        ((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a' pa, mvPointToward b' pb]}
+        closeDoor :: Wall -> Wall
+        closeDoor wl = case _wlLine wl of
+                        ((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a pa, mvPointToward b pb]}
+        changeZonedWall (!x,!y) 
+              = over wallsZone $ adjustIMZone openDoor x y n
+        changeZonedWall' (!x,!y) 
+              = over wallsZone $ adjustIMZone closeDoor x y n
+
+addAutoDoor :: Point2 -> Point2 -> World -> World
+addAutoDoor a b = over walls (autoDoorAt a b)
+
+removePathsCrossing :: Point2 -> Point2 -> World -> World
+removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
+                            $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
+                            w
+    where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
+          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+          newGraph = pairsToGraph dist pg'
+
+putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
+putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
+    where pairs = zip (p:ps) (ps ++ [p])
+          wWithBlock = addBlock (p:ps) i c b is w
+
+putWindowBlock :: Point2 -> Point2 -> World -> World
+--putWindowBlock a b w = foldr makeBlockAt w $ zip ps ns
+putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
+    where d = dist a b
+          rot = argV (b -.- a)
+          numPoints' = floor (d / 20)
+          numPoints = numPoints'*2
+          ns = take (numPoints+1) [0..]
+          ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) 
+                   $ map fromIntegral ns
+          k = newKey $ _walls w
+          ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3]
+          bSide = d / (fromIntegral numPoints)
+          ds = [(-bSide,-10),(-bSide,10),(bSide,10),(bSide,-10)]
+          polyAtP p = map ((+.+) p . rotateV rot) ds
+          hp = 1
+          degradeHP = [5,5]
+          winCol = withAlpha 0.5 cyan
+          makeBlockAt :: (Point2,Int) -> World -> World
+          makeBlockAt (p,i) w = 
+            let (k0:k1:k2:k3:_) = ksAtN i
+                (bl:tl:tr:br:_) = polyAtP p
+                shadows | i == 0 = ksAtN 1
+                        | i == numPoints - 1 = ksAtN $ numPoints - 2
+                        | otherwise = ksAtN (i-1) ++ ksAtN (i+1)
+                seen | even i    = True
+                     | otherwise = False
+                isLeftmost | i == 0 = True
+                           | otherwise = False
+                isRightmost | i == numPoints = True
+                            | otherwise = False
+                l = Block 
+                        { _wlLine = [bl,tl]
+                        , _wlID = k0
+                        , _wlColor = winCol
+                        , _wlDraw = Nothing
+                        , _wlSeen = False
+                        , _blIDs = ksAtN i
+                        , _blHP = hp
+                        , _wlIsSeeThrough = True
+                        --, _blVisible = False
+                        , _blVisible = isLeftmost
+                        , _blShadows = shadows
+                        , _blDegrades = degradeHP
+                        }
+                t = Block 
+                        { _wlLine = [tl,tr]
+                        , _wlID = k1
+                        , _wlColor = winCol
+                        , _wlDraw = Nothing
+                        , _wlSeen = False
+                        , _blIDs = ksAtN i
+                        , _blHP = hp
+                        , _wlIsSeeThrough = True
+                        , _blVisible = seen
+                        , _blShadows = shadows
+                        , _blDegrades = degradeHP
+                        }
+                r = Block 
+                        { _wlLine = [tr,br]
+                        , _wlID = k2
+                        , _wlColor = winCol
+                        , _wlDraw = Nothing
+                        , _wlSeen = False
+                        , _blIDs = ksAtN i
+                        , _blHP = hp
+                        , _wlIsSeeThrough = True
+                        --, _blVisible = False
+                        , _blVisible = isRightmost
+                        , _blShadows = shadows
+                        , _blDegrades = degradeHP
+                        }
+                b = Block 
+                        { _wlLine = [br,bl]
+                        , _wlID = k3
+                        , _wlColor = winCol
+                        , _wlDraw = Nothing
+                        , _wlSeen = False
+                        , _blIDs = ksAtN i
+                        , _blHP = hp
+                        , _wlIsSeeThrough = True
+                        , _blVisible = seen
+                        , _blShadows = shadows
+                        , _blDegrades = degradeHP
+                        }
+                f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
+            in  over walls f w
+                                    
+autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
+    where i = newKey wls
+          is = [i..]
+
+mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
+mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
+                               xs
+                               [ [pld,hwd]
+                               , [hwd,hwu]
+                               , [hwu,plu]
+                               , [pru,hwu]
+                               , [hwu,hwd]
+                               , [hwd,prd]
+                               ]
+                               [ [plld,pld]
+                               , [pld,plu]
+                               , [plu,pllu]
+                               , [prru,pru]
+                               , [pru,prd]
+                               , [prd,prrd]
+                               ]
+    where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
+          hw = 0.5 *.* (pl +.+ pr)
+          perp = 20 *.* normalizeV (pl -.- pr)
+          plu = pl +.+ norm
+          pld = pl -.- norm
+          pru = pr +.+ norm
+          prd = pr -.- norm
+          hwu = hw +.+ norm
+          hwd = hw -.- norm
+          pllu = plu +.+ perp
+          plld = pld +.+ perp
+          prru = pru -.- perp
+          prrd = prd -.- perp
+          addSound (x:xs) = f x : xs
+          f wl = over doorMech g wl
+          g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 
+                                                                    $ dm w
+                 | otherwise = dm w
+            where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
+
+mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
+mvPointTowardAtSpeed speed !ep !p 
+    | dist p ep < speed = ep
+    | otherwise         = p +.+ speed *.* normalizeV (ep -.- p)
+
+mvPointToward :: Point2 -> Point2 -> Point2
+mvPointToward ep p | dist p ep < 1 = ep
+                   | otherwise     = p +.+ normalizeV (ep -.- p)
+
+drawAutoDoor :: Wall -> Drawing
+drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] 
+        $ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y]
+                   ,color (dark c) $ line [x,y]
+                   ]
+    where 
+        (x:y:_) = _wlLine wl
+        c = _wlColor wl
+        nm = errorNormalizeV 543 (y -.- x)
+        t = 5 *.* nm
+        n = vNormal t
+        n2 = 3 *.* n
+        layer2 | _wlIsSeeThrough wl = 0
+               | isJust $ wl ^? doorMech = 1
+               | otherwise = 2
+
+autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
+autoDoorPane trigL n [a,b] [a',b'] = AutoDoor
+    { _wlLine = [a,b]
+    , _wlID = n
+    , _doorMech = dm
+    , _wlColor = dim $ yellow
+    , _wlDraw = Just drawAutoDoor
+    , _wlSeen = False
+    , _wlIsSeeThrough = False
+--    , _doorLine = [a,b,a',b']
+    }
+    where 
+        dm w | crsNearLine 40 trigL w 
+                         = flip (foldr changeZonedWall) zoneps
+                           $ over walls (IM.adjust openDoor n) w
+             | otherwise = flip (foldr changeZonedWall') zoneps
+                           $ over walls (IM.adjust closeDoor n) w
+        mvP !ep !p = mvPointTowardAtSpeed 2 ep p
+        openDoor :: Wall -> Wall
+        openDoor wl = case _wlLine wl of
+                        ((!pa):(!pb):_) -> wl {_wlLine = [mvP a' pa, mvP b' pb]}
+        closeDoor :: Wall -> Wall
+        closeDoor wl = case _wlLine wl of
+                        ((!pa):(!pb):_) -> wl {_wlLine = [mvP a pa, mvP b pb]}
+        zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
+               | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
+        changeZonedWall (!x,!y) 
+              = over wallsZone $ adjustIMZone openDoor x y n
+        changeZonedWall' (!x,!y) 
+              = over wallsZone $ adjustIMZone closeDoor x y n
+
+shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
+
+addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall
+addWindow qs c wls = foldr (addPane c) wls pairs
+    where (p:ps) = orderPolygon qs
+          pairs = zip (ps ++ [p]) (p:ps)
+addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
+addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1]
+                                                     , _wlID = newKey wls
+                                                     , _wlColor = c
+                                                     , _wlDraw = Nothing
+                                                     , _wlSeen = False 
+                                                     , _wlIsSeeThrough = True
+                                                     }
+                                               ) wls
+
+
+placeBt bt p rot w = over buttons addBT w
+    where addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
+placeFlIt fi p rot w = over floorItems addFI w
+    where addFI fis = IM.insert (newKey fis) (fi {_flItPos = p, _flItRot = rot, _flItID = newKey fis}) fis
+placePressPlate pp p rot w = over pressPlates addPP w
+    where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
+
+-- Left elements get new children, Right elements inherit the children from the
+-- mapped over node
+expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
+expandTreeBy f (Node x []) = fmap removeEither (f x)
+    where removeEither (Left y)  = y
+          removeEither (Right y) = y
+expandTreeBy f (Node x xs) = appendAndRemove $ f x
+    where appendAndRemove (Node (Left y)  ys) = Node y (map appendAndRemove ys)
+          appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
+
+expandTreeRand :: RandomGen g => 
+        (a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
+expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
+    where removeEither (Left y)  = y
+          removeEither (Right y) = y
+expandTreeRand f (Node x xs) = do
+    root <- f x
+    branches <- sequence $ map (expandTreeRand f) xs
+    return (appendAndRemove branches root)
+        where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
+              appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
+              appendAndRemove bran (Node (Right y) _) = Node y bran
+
+placeCr :: Creature -> Point2 -> Float -> World -> World
+placeCr crF p rot w = over creatures addCr w
+    where addCr crs = IM.insert (newKey crs) 
+                                (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs}) 
+                                crs
+
+placeLS :: LightSource -> Drawing -> Point2 -> Float -> World -> World
+placeLS ls dec p rot w = over lightSources addLS 
+                            $ over decorations addDec w
+    where addLS lss = IM.insert (newKey lss) 
+                                (ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss}) 
+                                lss
+          addDec decs = IM.insert (newKey decs) 
+                                  (uncurry translate p $ rotate (radToDeg rot) dec)
+                                  decs
+
+

src/Dodge/LightSources.hs

@@ -0,0 +1,25 @@
+module Dodge.LightSources where
+import Dodge.Data
+import Dodge.Base
+
+import Geometry
+import Picture
+
+--import Graphics.Gloss
+--import Graphics.Gloss.Data.Vector
+--import Graphics.Gloss.Geometry.Line
+--import Graphics.Gloss.Geometry.Angle
+
+import qualified Data.IntMap.Strict as IM
+
+lightAt p i = 
+    LS {_lsID = i
+       ,_lsPos = p
+       ,_lsDir = 0
+       ,_lsRad = 300
+       ,_lsIntensity = 0.25
+       }
+
+basicLS = PutLS ls dec
+    where ls = lightAt (0,0) 0
+          dec = onLayer PtLayer $ color white $ circleSolid 8

src/Dodge/LoadSound.hs

@@ -0,0 +1,137 @@
+module Dodge.LoadSound where
+-- imports {{{
+import Dodge.Data
+
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+
+import Control.Monad
+import Control.Lens
+
+import qualified SDL.Mixer as Mix
+
+-- }}}
+loadSounds :: IO (IM.IntMap Mix.Chunk)
+loadSounds = do
+--    pFireSound <- Mix.load "./data/sound/tap3.wav"
+    pFireSound <- Mix.load "./data/sound/tap3.wav"
+    click <- Mix.load "./data/sound/click1.wav"
+    reloadSound' <- Mix.load "./data/sound/reload1.wav"
+    tone440 <- Mix.load "./data/sound/tone440.wav"
+    pickupSound' <- Mix.load "./data/sound/pickUp.wav"
+    putdownSound' <- Mix.load "./data/sound/whiteNoiseFadeOut.wav"
+    fireSound' <- Mix.load "./data/sound/fire1.wav"
+    grenadeBang' <- Mix.load "./data/sound/grenade.wav"
+    tapQuiet' <- Mix.load "./data/sound/tapQuiet.wav"
+    twoStep' <- Mix.load "./data/sound/twoStep.wav"
+    healSound' <- Mix.load "./data/sound/heal.wav"
+    doorSound' <- Mix.load "./data/sound/slideDoor.wav"
+    twoStepSlow' <- Mix.load "./data/sound/twoStepSlow.wav"
+    knifeSound' <- Mix.load "./data/sound/knife.wav"
+    buzzSound' <- Mix.load "./data/sound/buzz.wav"
+    hitSound' <- Mix.load "./data/sound/hit1.wav"
+    autoGunSound' <- Mix.load "./data/sound/autoGun.wav"
+    shotgunSound' <- Mix.load "./data/sound/shotgun.wav"
+    teleSound' <- Mix.load "./data/sound/tele.wav"
+    longGunSound' <- Mix.load "./data/sound/longTap.wav"
+    launcherSound' <- Mix.load "./data/sound/tap4.wav"
+    smokeTrailSound' <- Mix.load "./data/sound/missileLaunch.wav"
+    foot1Sound' <- Mix.load "./data/sound/foot1.wav"
+    foot2Sound' <- Mix.load "./data/sound/foot2.wav"
+    lasSound' <- Mix.load "./data/sound/tone440sawtooth.wav"
+    teslaSound' <- Mix.load "./data/sound/Electrical-Welding.wav" 
+    crankSlow' <- Mix.load "./data/sound/crankSlow.wav" 
+    autoB' <- Mix.load "./data/sound/autoB.wav" 
+    mini' <- Mix.load "./data/sound/mini1.wav" 
+    impactA' <- Mix.load "./data/sound/Impact-A.wav" 
+    impactB' <- Mix.load "./data/sound/Impact-B.wav" 
+    impactC' <- Mix.load "./data/sound/Impact-C.wav" 
+    impactD' <- Mix.load "./data/sound/Impact-D.wav" 
+    glassShat1' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A1.wav" 
+    glassShat2' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A2.wav" 
+    glassShat3' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A3.wav" 
+    glassShat4' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A4.wav" 
+    glass1' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A1.wav" 
+    glass2' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A2.wav" 
+    glass3' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A3.wav" 
+    glass4' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A4.wav" 
+    foamSpray' <- Mix.load "./data/sound/foamSprayLoop.wav" 
+    return $ IM.fromList $ zip [0..] 
+                         $ [ pFireSound
+                           , click
+                           , reloadSound'
+                           , tone440
+                           , pickupSound'
+                           , putdownSound'
+                           , fireSound'
+                           , grenadeBang'
+                           , tapQuiet'
+                           , twoStep'
+                           , healSound'
+                           , doorSound'
+                           , twoStepSlow'
+                           , knifeSound'
+                           , buzzSound'
+                           , hitSound'      --15
+                           , autoGunSound'
+                           , shotgunSound'
+                           , teleSound'
+                           , longGunSound'
+                           , launcherSound'
+                           , smokeTrailSound'
+                           , foot1Sound'
+                           , foot2Sound'
+                           , lasSound'
+                           , teslaSound'  --25
+                           , crankSlow'  
+                           , autoB'
+                           , mini'
+                           , impactA'
+                           , impactB'  --30
+                           , impactC'
+                           , impactD'
+                           , glassShat1' --33
+                           , glassShat2'
+                           , glassShat3'
+                           , glassShat4'
+                           , glass1'    --37
+                           , glass2'
+                           , glass3'
+                           , glass4'    --40
+                           , foamSpray'
+                           ]
+
+-- updateSound :: World -> IO World
+-- updateSound  w 
+--     = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) 0 (_loadedSounds w IM.! n))
+--          fmap (set soundQueue creatureSounds) $ stepSoundTimers $ w
+-- --      = return $ set soundQueue creatureSounds w
+--   --  = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) (_loadedSounds w IM.! n) 0)
+--   --       fmap (set soundQueue creatureSounds) $ return w
+--     where creatureSounds = []
+
+soundOnce :: Int -> World -> World
+soundOnce i = over soundQueue ((:) i)
+
+--stepSoundTimers :: World -> IO World
+--stepSoundTimers w = M.foldrWithKey stepSoundTimer (return w) (_sounds w)
+
+-- ok, this is hard to reason about-- bugs can occur because I am unsure when
+-- everything is evaluated
+--stepSoundTimer :: SoundOrigin -> Sound -> IO World -> IO World
+--stepSoundTimer so s w = 
+--    case _soundChannel s of
+--        Nothing -> do w1 <- w
+--                      let soundChunk = _loadedSounds w1 IM.! _soundType s
+----                      n <- Mix.playingCount
+--                      channel <- Mix.playOn (-1) (-1) soundChunk
+--                      -- w2 <- w -- Note that using w2 instead of w1 in the
+--                                 -- final return breaks the sound sometimes, must be
+--                                 -- something to do with order of evaluation
+--                      return $ set (sounds . ix so . soundChannel) (Just $ fromIntegral channel) w1
+--        Just channel -> case _soundTime s of
+--                                x | x > 0     -> fmap (set (sounds . ix so . soundTime) (x-1)) w
+--                                  | x <= 0 -> do Mix.fadeOut channel (fromIntegral $ _soundFadeTime s+ 1)
+--                                                 fmap (over sounds (M.delete so)) w
+-- the sound fade doesn't seem to like being 0

src/Dodge/Menu.hs

@@ -0,0 +1,103 @@
+module Dodge.Menu where
+-- imports {{{
+import Dodge.Data
+import Dodge.Rooms
+import Dodge.Initialisation
+import Dodge.SoundLogic
+
+import Data.Tree
+import Data.Maybe
+import qualified Data.Set as S
+
+import Control.Lens
+import Control.Monad
+import Control.Monad.State
+
+
+import System.Exit
+import System.Random
+
+--import Graphics.Gloss.Interface.IO.Game
+import SDL
+-- }}}
+
+keyPressedDown :: Event -> Maybe Keycode
+keyPressedDown e = case eventPayload e of
+    KeyboardEvent (KeyboardEventData _ Pressed False keysym) -> Just $ keysymKeycode keysym
+    _ -> Nothing
+
+menuEvents :: (Event -> World -> Maybe World) -> Event -> World -> Maybe World
+menuEvents f e w = case _menuState w of
+    LevelMenu _ -> case keyPressedDown e of
+            Just KeycodeEscape -> Nothing
+            Just _             -> startLevel w >>= f e
+            _                  -> Just w
+    PauseMenu -> case keyPressedDown e of
+            Just KeycodeEscape -> Nothing
+            Just KeycodeR      -> return $ fromMaybe w $ _storedLevel w
+            Just KeycodeN      -> Just $ putSound $ generateLevel 1 
+                                           $ initialWorld {_randGen = _randGen w}
+            Just _             -> unpause w >>= f e
+            _                  -> Just w
+    GameOverMenu -> case keyPressedDown e of
+            Just KeycodeEscape -> Nothing
+            Just KeycodeR      -> Just $ fromMaybe w $ _storedLevel w
+            Just KeycodeN      -> Just $ putSound $ generateLevel 1 
+                                                            $ initialWorld
+                                                                {_randGen = _randGen w}
+            _                              -> return w
+    _ -> f e w
+    where unpause w' = Just $ resumeSound $
+                        w' {_menuState = InGame,_keys = S.empty}
+          startLevel = unpause . storeLevel
+          putSound = id -- set loadedSounds (_loadedSounds w)
+    
+
+---  menuCheckKeyEvents :: (Event -> World -> IO World) -> Event -> World -> IO World
+---  menuCheckKeyEvents f e w = case _menuState w of
+---      LevelMenu _ -> case e of
+---              (EventKey (SpecialKey KeyEsc) Down _ _) 
+---                                             -> exitSuccess
+---              (EventKey _ Down _ _) -> startLevel w >>= f e
+---              _                              -> return w
+---      PauseMenu -> case e of
+---              (EventKey (SpecialKey KeyEsc) Down _ _) 
+---                                             -> exitSuccess
+---              (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
+---              (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1 
+---                                                              $ initialWorld 
+---                                                                  {_randGen = _randGen w}
+---  --            (EventKey (Char 'c') Down _ _) -> unpaused
+---  --            (EventKey (Char 'p') Down _ _) -> unpaused
+---  --            (EventKey (SpecialKey KeySpace) Down _ _) -> unpaused
+---              (EventKey _ Down _ _) -> unpause w >>= f e
+---              _                              -> return w
+---      GameOverMenu -> case e of
+---              (EventKey (SpecialKey KeyEsc) Down _ _) 
+---                                             -> exitSuccess
+---              (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
+---              (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1 
+---                                                              $ initialWorld
+---                                                                  {_randGen = _randGen w}
+---  --            (EventKey (Char 'c') Down _ _) -> unpaused
+---              _                              -> return w
+---      _ -> f e w
+---      where unpause w' = do Mix.resume (-1)
+---                            return w' {_menuState = InGame,_keys = S.empty}
+---            startLevel = unpause . storeLevel
+---            putSound = set loadedSounds (_loadedSounds w)
+---  -- there might be a better way to pass the loaded sounds around
+
+updateRandGen :: World -> World
+updateRandGen = over randGen (fst . split)
+
+menuCheckUpdate :: (Float -> World -> IO World) -> Float -> World -> IO World
+menuCheckUpdate f t w = case _menuState w of
+    InGame -> f t w
+    _      -> return w
+
+storeLevel :: World -> World
+storeLevel w = case _storedLevel w of
+                 Nothing -> set storedLevel (Just w) w
+                 _       -> w
+

src/Dodge/Path.hs

@@ -0,0 +1,171 @@
+module Dodge.Path where
+import Dodge.Data
+import Dodge.Base
+
+import Geometry
+
+import Control.Monad
+
+import Data.List
+import Data.Maybe
+import Data.Function
+import Data.Graph.Inductive.Graph
+import qualified Data.HashSet as HS
+import qualified Data.Heap as HP
+
+import qualified Data.Map as M
+
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.PatriciaTree
+import Data.Graph.Inductive.Query.SP
+
+worldGraph :: World -> Point2 -> HS.HashSet Point2
+worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q)) 
+                               [(200,0),(-200,0),(0,200),(0,-200)]
+
+pointsAlong :: World -> Point2 -> Point2 -> [Point2]
+pointsAlong w p q = divideLineFixed 50 p p'
+    where p' = furthestPointWalkable p q $ wallsAlongLine p q w
+
+divideLineFixed :: Float -> Point2 -> Point2 -> [Point2]
+divideLineFixed x a b = fmap (\i -> a +.+ i * x *.* normalizeV (b -.- a)) 
+                       $ fmap fromIntegral ns
+    where numPoints = floor $ dist a b / x
+          ns = [1 .. numPoints]
+
+-- ok, astar or something like it
+
+type SearchedNodes = (HP.MinHeap (Float,(Float,[Point2])), [Point2])
+
+stripRight :: Either a b -> b
+stripRight (Right x) = x
+
+stepPath :: (Point2 -> [Point2]) -> Point2 
+            -> SearchedNodes -> Either [Point2] SearchedNodes
+stepPath f p (nextNodes, seenNodes)
+    = case HP.view nextNodes of
+            Nothing -> Left []
+            Just ((_,(cost,(q:qs))), nextNodes') 
+                | q == p -> Left (q:qs)
+                | otherwise -> let rs' = f q
+                                   rs = rs' \\ seenNodes
+                                   newNodes = map (\r -> (cost + dist q r + dist r p
+                                                         ,  (cost + dist q r
+                                                            , (r:q:qs)
+                                                            )
+                                                         )
+                                                  ) rs
+                               in  Right $ (foldr HP.insert nextNodes' newNodes
+                                           , rs ++ seenNodes
+                                           )
+stepPath' :: (Point2 -> [Point2]) -> Point2 
+            -> SearchedNodes -> [Point2]
+stepPath' f p s = case stepPath f p s of Left ps -> ps
+                                         Right s' -> stepPath' f p s'
+
+makePath' :: (Point2 -> [Point2]) -> Point2 -> Point2 -> [Point2]
+makePath' f s e = stepPath' f e $ (HP.singleton (0,(0,[s])) , [])
+
+makeNode :: Point2 -> SearchedNodes
+makeNode e = (HP.singleton (0,(0,[e])) , [])
+
+
+tp1,tp2,tp3 :: Point2
+tp1 = (0,1)
+tp2 = (0,20)
+tp3 = (30,40)
+
+f = incidenceToFunction $ pairsToIncidence [(tp1,tp2),(tp2,tp3)
+                                           ,(tp2,tp1)
+                                           ,(tp1,tp3)]
+g = pairsToIncidence [(tp1,tp2),(tp2,tp3)
+                                           ,(tp2,tp1)
+                                           ,(tp1,tp3)]
+
+pathBetween :: Point2 -> Point2 -> World -> Maybe [Point2]
+pathBetween a b w = makePath' <$> return (\p -> _pathInc w M.! p) <*> a' <*> b'
+    where
+          nsa :: [Point2]
+          nsa = map snd $ concat $ lookLookups (zoneAroundPoint a) (_pathPoints w)
+          nsb = map snd $ concat $ lookLookups (zoneAroundPoint b) (_pathPoints w)
+          --a' = listToMaybe $ sortBy (compare `on` dist a) $ ns
+          --b' = listToMaybe $ sortBy (compare `on` dist b) $ ns
+          a' = listToMaybe $ filter (flip (isWalkable a) w)  nsa
+          b' = listToMaybe $ filter (flip (isWalkable b) w)  nsb
+
+
+
+----
+
+makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
+makePathBetween a b w =  join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g
+    where g  = _pathGraph w
+          nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w)
+          nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w)
+--          a' = listToMaybe $ sortBy (compare `on` dist a . snd) $ filter (flip (isWalkable a) w . snd) ns
+--          b' = listToMaybe $ sortBy (compare `on` dist b . snd) $ filter (flip (isWalkable b) w . snd) ns
+          a' = listToMaybe $ filter (flip (isWalkable a) w . snd) nsa
+          b' = listToMaybe $ filter (flip (isWalkable b) w . snd) nsb
+
+
+
+ezipWith :: Monoid a => (b -> c -> d) -> Either a b -> Either a c -> Either a d
+ezipWith f (Right x) (Right y) = Right (f x y)
+ezipWith f (Left  x) (Right _) = Left x
+ezipWith f (Right _) (Left  y) = Left y
+ezipWith f (Left  x) (Left  y) = Left (mappend x y)
+
+
+makePathBetween' :: Point2 -> Point2 -> World -> Either String [Int]
+makePathBetween' a b w = let g  = _pathGraph w
+                             ns = labNodes g
+                             nsa = (_pathPoints w) `ixNZ` a
+                             nsb = (_pathPoints w) `ixNZ` b
+                             a' = case listToMaybe $ sortBy (compare `on` dist a . snd) 
+                --             a' = case listToMaybe 
+                                                   $ filter (flip (isWalkable a) w . snd) ns of
+                                         Just p -> Right $ fst p
+                                         _      -> Left "FIRST POINT UNSEEN"
+                             b' = case listToMaybe $ sortBy (compare `on` dist b . snd) 
+                --             b' = case listToMaybe 
+                                                   $ filter (flip (isWalkable b) w . snd) ns of
+                                         Just p -> Right $ fst p
+                                         _      -> Left $ "SECOND POINT UNSEEN" ++ show b
+                         in  case ezipWith (\x y -> sp x y g) a' b' of
+                                        Right (Just xs) -> Right xs
+                                        Right (Nothing) -> Left $ "NO PATH" ++ show a ++ show b ++ show a' ++ show b'
+                                        Left m          -> Left m
+
+makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
+--makePathBetweenPs a b = pathBetween a b
+makePathBetweenPs a b w =  fmap (mapMaybe (lab g)) $ makePathBetween b a w
+    where g  = _pathGraph w
+
+makePathBetweenPs' :: Point2 -> Point2 -> World -> Either String [Point2]
+makePathBetweenPs' a b w =  fmap (mapMaybe (lab g)) $ makePathBetween' a b w
+    where g  = _pathGraph w
+
+
+pointTowardsGoal :: Point2 -> Point2 -> World -> Maybe Point2
+pointTowardsGoal a b w = join $ fmap (listToMaybe . filter (flip (isWalkable a) w))
+--                              $ pathBetween a b w
+                                $ makePathBetweenPs a b w
+--
+    
+pointTowardsGoal' :: Point2 -> Point2 -> World -> Either String Point2
+pointTowardsGoal' a b w = join $ fmap (maybeToEither "NOSEEPATH" . listToMaybe . filter (flip (isWalkable a) w))
+                               $ makePathBetweenPs' b a w
+
+maybeToEither :: a -> Maybe b -> Either a b
+maybeToEither _ (Just x) = Right x
+maybeToEither y Nothing  = Left y
+
+pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
+pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip)
+                     . groupBy ( (==) `on` fst)
+                     . sort
+
+incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
+incidenceToFunction xs a = case lookup a xs of Just ys -> ys
+                                               Nothing -> []
+

src/Dodge/Prototypes.hs

@@ -0,0 +1,250 @@
+{-# LANGUAGE BangPatterns #-}
+module Dodge.Prototypes where
+
+import Dodge.Data
+import Dodge.SoundLogic
+import Dodge.Base
+
+import Geometry
+import Picture
+
+import Control.Lens
+
+import System.Random
+
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Graph.Inductive.Graph hiding ((&))
+import Data.List
+
+--import Graphics.Gloss
+--import Graphics.Gloss.Data.Vector
+
+-- defalt datatypes / prototypes {{{
+basicWall = Wall { _wlLine = [(0,0),(50,0)]
+                   , _wlID = 0
+                   , _wlColor = greyN 0.6
+                   , _wlDraw = Nothing
+                   , _wlSeen = False
+                   , _wlIsSeeThrough = False
+                   }
+basicAutoDoor = AutoDoor { _wlLine = [(0,0),(50,0)]
+                   , _wlID = 0
+                   , _doorMech = id
+                   , _wlColor = light $ dim $ dim $ dim $ yellow
+                   , _wlDraw = Nothing
+                   , _wlSeen = False
+                   , _wlIsSeeThrough = False
+                   }
+basicDoor = Door { _wlLine = [(0,0),(50,0)]
+                   , _wlID = 0
+                   , _doorMech = id
+                   , _wlColor = light $ dim $ dim $ dim $ yellow
+                   , _wlDraw = Nothing
+                   , _wlSeen = False
+                   , _wlIsSeeThrough = False
+                   }
+basicCreature :: Creature
+basicCreature = Creature
+    { _crPos = (0,0)
+    , _crOldPos = (0,0)
+    , _crDir = 0
+    , _crID = 1
+    , _crPict = const $ onLayer CrLayer $ circleSolid 10
+    , _crUpdate = \ w f cr -> (f , Just cr)
+    , _crRad = 10
+    , _crMass = 10
+    , _crHP = 100
+    , _crMaxHP = 150
+    , _crInv = IM.empty
+    , _crInvSel = 0
+    , _crAmmo = M.empty
+    , _crState = basicState
+    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
+    }
+basicState = CrSt { _goals = []
+                  , _stance = Stance {_carriage=Walking 0 0,_posture=AtEase}
+                  , _faction = NoFaction
+                  , _crDamage = []
+                  , _crPastDamage = 0
+                  , _crSpState = GenCr
+                  , _crApplyDamage = basicApplyDamage'
+                  }
+basicEquipment = Equipment
+    { _itIdentity = Generic
+    , _itName = "genericEquipment"
+    , _itMaxStack = 1
+    , _itAmount = 1
+    , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
+    , _itEquipPict = \cr _ -> blank
+    , _itEffect = NoItEffect
+    , _itHammer = HammerUp
+    , _itID = Nothing
+    , _itAimingSpeed = 1
+    , _itAimingRange = 0
+    , _itZoom = basicItZoom
+    , _itInvColor = yellow
+    , _itInvDisplay = _itName
+    }
+basicItZoom = ItZoom 20 0.2 1 20 0.2 1
+basicConsumable :: Item
+basicConsumable = Consumable
+    { _itIdentity = Generic
+    , _itName = "genericConsumable"
+    , _itMaxStack = 9
+    , _itAmount = 1
+    , _cnEffect = \_ _ -> Nothing
+    , _itFloorPict = onLayer FlItLayer $ color blue $ circleSolid 3
+    , _itEquipPict = \_ _ -> blank
+    , _itID = Nothing
+    , _itInvColor = blue
+    , _itInvDisplay = \it -> _itName it ++ " x" ++ show (_itAmount it)
+    , _itEffect = wpRecock
+    , _itHammer = HammerUp
+    }
+basicApplyDamage' :: [DamageType] -> Creature -> (World -> World, Creature)
+basicApplyDamage' ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ basicApplyDamage d c) cr ds')
+    where (ps,ds') = partition isPoison ds
+          isPoison (PoisonDam {}) = True
+          isPoison _ = False
+          poisonDam = quot (max 0 (sum (map _dmAmount ps) - 0)) 10
+          doPoisonDam = over crHP (\hp -> hp - poisonDam)
+
+basicApplyDamage :: DamageType -> Creature -> (World -> World, Creature)
+basicApplyDamage (Concussive amount from push pushexp pushRad) cr
+        = ( id
+          , over crHP (\hp -> hp - amount) 
+                $ over crPos (+.+ (pushAmount *.* safeNormalizeV (_crPos cr -.- from))) 
+                cr
+          )
+    where pushAmount | dist (_crPos cr) from == 0 
+                                 = 0
+                     | otherwise = min 5 $ 
+                        (push*5*pushRad / (dist (_crPos cr) from * _crMass cr))**pushexp
+basicApplyDamage (TorqueDam amount rot) cr
+    = ( id
+      , over crHP (\hp -> hp - amount) $ over crDir (+ rot) cr)
+basicApplyDamage (PushDam amount pback) cr
+    = ( id
+      , over crHP (\hp -> hp - amount) $ over crPos (+.+ ((1/_crMass cr) *.* pback )) cr
+      )
+basicApplyDamage dt cr 
+    = ( id , over crHP (\hp -> hp - _dmAmount dt) cr )
+basicFlIt = FlIt {_flItRot=0,_flIt = basicIt, _flItPos = (0,0), _flItID = 0}
+basicIt = Consumable
+    { _itIdentity = Medkit25
+    , _itName = "basicIt"
+    , _itMaxStack = 3
+    , _itAmount = 2
+    , _cnEffect = \ _ -> return
+    , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
+    , _itEquipPict = \cr _ -> blank
+    , _itID = Nothing
+    , _itInvDisplay = _itName
+    , _itInvColor = blue
+    , _itEffect = NoItEffect
+    , _itHammer = HammerUp
+    }
+basicButton = Button
+    { _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
+    , _btPos = (0,0)
+    , _btRot = 0
+    , _btEvent = \b w -> set (buttons . ix (_btID b) . btPict) 
+                             (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
+                         . set (buttons . ix (_btID b) . btState) BtNoLabel
+                         . soundOnce 1 $ w
+    , _btID = 0
+    , _btText = "Button"
+    , _btState = BtOff
+    }
+basicPT = Particle
+    { _ptPos = (0,0)
+    , _ptStartPos = (0,0)
+    , _ptVel = (0,0)
+    , _ptPict = blank
+    , _ptID = 0
+    , _ptUpdate = id
+    }
+basicPP = PressPlate
+    { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5
+    , _ppPos = (0,0)
+    , _ppRot = 0
+    , _ppEvent = \pp -> id
+    , _ppID = -1
+    , _ppText = "Pressure plate"
+    }
+-- }}}
+basicWorld = World
+    { _keys = S.empty
+    , _mouseButtons = S.empty
+    , _cameraPos = (0,0)
+    , _cameraAimTime = 0
+    , _cameraRot = 0
+    , _cameraZoom = 1
+    , _cameraCenter = (0,0)
+    , _creatures = IM.empty
+    , _creaturesZone = IM.empty
+    , _clouds = IM.empty
+    , _cloudsZone = IM.empty
+    , _itemPositions = IM.empty
+    , _particles = IM.empty
+    , _particles' = []
+    , _afterParticles' = []
+    , _walls = IM.empty
+    , _wallsZone = IM.empty
+    , _forceFields = IM.empty
+    , _floorItems = IM.empty
+    , _randGen = mkStdGen 2
+    , _mousePos = (0,0)
+    , _testString = []
+    , _yourID = 0
+    , _worldEvents = id
+    , _pressPlates = IM.empty
+    , _buttons = IM.empty
+    , _soundQueue = []
+--    , _loadedSounds = IM.empty
+    , _sounds = M.empty
+    , _corpses = IM.empty
+    , _decorations = IM.empty
+    , _unlimitedAmmo = True
+    , _storedLevel = Nothing
+    , _menuState = LevelMenu 1
+    , _worldState = M.empty
+    , _lbClickMousePos = (0,0)
+    , _lbRotation = 0
+    , _pathGraph = Data.Graph.Inductive.Graph.empty
+    , _pathGraph' = []
+    , _pathPoints = IM.empty
+    , _pathInc = M.empty
+    , _windowX = 800
+    , _windowY = 840
+    , _smoke = []
+    , _mapDisplay = (False, 0.2)
+    , _lightSources = IM.empty
+    , _tempLightSources = [youLight]
+    }
+youLight = 
+--    LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) 
+    TLS { _tlsPos = (0,0)
+        ,_tlsRad = 300
+        ,_tlsIntensity = 0.1
+        ,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = _crPos (you w)}))
+        }
+
+
+wpRecock :: ItEffect
+--wpRecock = NoItEffect
+wpRecock = ItInvEffect {_itInvEffect = f
+                       ,_itEffectCounter = 0
+                       }
+    where f cr i = creatures . ix (_crID cr) . crInv 
+                           --  . ix i . itHammer %~ ($!) (fmap $! (moveHammerUp `seq` moveHammerUp))
+                           --  . ix i . itHammer %~ ($!) (fmap $! moveHammerUp)
+                           --  . ix i . itHammer . _Just %~ ($!) moveHammerUp
+                           %~ IM.adjust fOnIt i
+          moveHammerUp !HammerDown = HammerReleased
+          moveHammerUp !HammerReleased = HammerUp
+          moveHammerUp !HammerUp       = HammerUp
+          fOnIt it = it & itHammer %~ moveHammerUp
+

src/Dodge/RandomHelp.hs

@@ -0,0 +1,66 @@
+module Dodge.RandomHelp where
+
+import Geometry
+import Geometry.Data
+
+import System.Random
+import Control.Monad.State
+import Data.List
+
+randomRanges :: (Random a,RandomGen g) => [a] -> State g a
+randomRanges xs = join $ takeOne $ f xs
+    where f (x:y:ys) = (state (randomR (x,y))) : (f ys)
+          f  _ = []
+
+takeOne :: RandomGen g => [a] -> State g a
+takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i))
+
+takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a
+takeOneWeighted ws xs = state (randomR (0, sum ws))
+                            >>= (\w -> return (xs !! (i w ws)))
+    where i y (z:zs) | y <= z = 0
+                     | otherwise = 1 + i (y-z) zs
+          i y _ = 0
+
+takeOneMore :: RandomGen g => ([a],[a]) -> State g ([a],[a])
+takeOneMore (xs,ys) = do
+    i <- state $ randomR (0,length ys - 1)
+    let (zs, w:ws) = splitAt i ys
+    return (w:xs, zs ++ ws)
+
+takeNMore :: RandomGen g => Int -> ([a],[a]) -> State g ([a],[a])
+takeNMore n p = foldr (const ((=<<) takeOneMore)) (return p) [1..n]
+
+takeN :: RandomGen g => Int -> [a] -> State g [a]
+takeN i xs = fmap fst $ takeNMore i ([],xs)
+
+-- to randomly shuffle a list
+shuffle :: RandomGen g => [a] -> State g [a]
+shuffle xs = do 
+    let l = length xs
+    rands <- forM [0..l-1] $ \i -> state $ randomR (0,i)
+    let f ys rand = let (as,b:bs) = splitAt rand ys
+                    in  (as ++ bs, b)
+    let (_,zs) = mapAccumR f xs rands
+    return zs
+
+randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
+randomSelectionFromList p = filterM $ const $ randProb p
+
+randProb :: RandomGen g => Float -> State g Bool
+randProb p = do p1 <- state $ randomR (0,1)
+                return (p1 < p)
+
+randInCirc :: RandomGen g => Float -> State g Point2
+randInCirc maxRad = do rad <- state $ randomR (0,maxRad)
+                       ang <- state $ randomR (0,2*pi)
+                       return $ rad *.* unitVectorAtAngle ang
+
+randInRect :: RandomGen g => Float -> Float -> State g Point2
+randInRect w h = do x <- state $ randomR (0,w)
+                    y <- state $ randomR (0,h)
+                    return (x,y)
+
+maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
+maybeTakeOne [] = return Nothing
+maybeTakeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (Just (xs !! i)))

src/Dodge/Rendering.hs

@@ -0,0 +1,512 @@
+module Dodge.Rendering where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Geometry
+import Picture
+
+import Data.Graph.Inductive.Query.DFS
+import Data.Graph.Inductive.Graph
+
+import Control.Monad.State
+import Data.List
+import Data.Bifunctor
+
+
+import Data.Function
+import Control.Applicative
+import Control.Lens
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+-- }}}
+--
+drawTest :: World -> Picture
+drawTest w = screenT $ color red $  circle 200
+    where (x,y) = (_windowX w,_windowY w)
+          screenT = scale (1/x) (1/y)
+
+
+draw' :: Picture -> World -> ([((Float,Float),(Float,Float))]
+                             ,[((Float,Float),Float,Float)]
+                             ,Picture,Picture)
+draw' p w = (\(x,y) -> (wallsForGloom w,lightsForGloom w,x,y)) (draw'' p w)
+
+draw :: Picture -> World -> Picture
+draw p w = (\(x,y) -> f $ pictures [x,y]) $ draw'' p w
+    where f = scale (2/_windowX w) (2/_windowY w)
+
+draw'' :: Picture -> World -> (Picture , Picture)
+draw'' b w-- | (Char 'm') `S.member` _keys w
+        --            = let a = (-500,30)
+        --                  b = (200,0)
+        --              in pictures [ color white $ polygon screenBox
+        --                       , color blue $ circleSolid 40
+        --                       , line [a,b]
+        --                       , uncurry translate (ssaTriPoint a (0,0) b 40)
+        --                                  $ color red  $ circleSolid 5
+        --                       ]
+    = case _mapDisplay w of
+         (True, z) -> (blank
+                      ,pictures [color white $ circleSolid 3
+                                ,scale z z $ rotate (radToDeg (_cameraRot w))
+                                    $ uncurry translate ((0,0) -.- _cameraCenter w) 
+                                    $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w]
+                       ) 
+         _ -> ( blank
+              --,pictures $ map fst pics
+              ,collectDrawings w
+              )
+--                    ++ map screenShift (pathsTest ++ map drawNode (labNodes $ _pathGraph w))
+    where yourPos = _crPos $ you w
+          backgroundTile = [screenShift $ translate (5*512*x) (5*512*y) $ scale 5 5 b | x <- [x1..x2] , y <- [y1..y2] ]
+                where (x',y') = yourPos
+                      (x'',y'') = (fromIntegral $ round (x'/(512*5)), fromIntegral $ round (y'/(512*5)))
+                      x1 = (x''-1)
+                      x2 = (x''+1)
+                      y1 = (y''-1)
+                      y2 = (y''+1)
+          screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
+                                            . uncurry translate ((0,0) -.- _cameraPos w)
+          zoom = _cameraZoom w
+          pathsTest = map drawPair $ _pathGraph' w
+          drawPair (x,y) = color cyan $ pictures [line [x,y]
+                           --         , uncurry translate x $ scale 0.05 0.05 $ text $ show x
+                                    ]
+          drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i
+
+collectDrawings :: World -> Picture
+collectDrawings w = screenShift (decPicts <> ppPicts <> itFloorPicts 
+                                <> crPicts
+                                <> clPicts
+                                   <> buttonPicts <> ptPicts 
+                                    <> ptPicts'
+                                    <> afterPtPicts'
+                                <> wlPicts
+                                <> wallShadows
+                                <> smokeShadows
+                                )
+                                <> onLayer LabelLayer
+                                        (itLabels <> ppLabels <> btLabels)
+                                <> hudDrawings w
+                                <> onLayer MenuLayer menuScreen
+--                                <> [onLayer GloomLayer $ theLighting w]
+    where
+          screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
+                                            . uncurry translate ((0,0) -.- _cameraPos w)
+          rotPicts = map (scale zoom zoom . rotate (radToDeg (_cameraRot w)))
+          zoom     = _cameraZoom w
+          decPicts :: Picture
+          decPicts      = mconcat $ IM.elems $ _decorations w
+          ptPicts       = mconcat $ map _ptPict (IM.elems (_particles w))
+          ptPicts'      = mconcat $ map _ptPict' $ _particles' w
+          afterPtPicts' = mconcat $ map _ptPict' $ _afterParticles' w
+          buttonPicts   = mconcat $ map btDraw (IM.elems (_buttons w))
+          ppPicts       = mconcat $ map ppDraw (IM.elems (_pressPlates w))
+          crPicts :: Picture
+          crPicts       = mconcat $ map crDraw $ IM.elems $ _creatures w
+          clPicts       = mconcat $ map clDraw $ IM.elems $ _clouds w
+          wallShadows   = mconcat $ map (drawWallShadow w) $ wallShadowsToDraw w
+          smokeShadows  = mconcat $ map (drawSmokeShadow w) $ _smoke w
+          wlPicts       = mconcat $ map drawWall (wallsToDraw w)
+          yourPos = _crPos $ you w
+          yourRot = _crDir $ you w
+          yourRad = _crRad $ you w
+         -- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w)))
+         --                                       (map (_itFloorPict . _flIt) (IM.elems (_floorItems w)))
+          itFloorPicts = mconcat $ map (drawItem) (IM.elems (_floorItems w))
+          itLabels     = mconcat $ map (drawItemName w) (IM.elems (_floorItems w))
+          ppLabels     = mconcat $ map (drawPPText w) (IM.elems (_pressPlates w))
+          btLabels     = mconcat $ map (drawButText w) (IM.elems (_buttons w))
+          menuScreen :: Picture
+          menuScreen = case _menuState w of
+                        InGame -> blank 
+                        LevelMenu x -> 
+                            mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                            ,tst (-100) 100 0.4 ("LEVEL "++show x)
+                            ] <> controlsList
+                        PauseMenu   -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                                    ,tst (-100) 100 0.4 "PAUSED"
+                                    ,tst (-100) 50 0.2 "n - new level"
+                                    ,tst (-100) 0 0.2 "r - restart"
+                                    ] <> controlsList
+                        GameOverMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                                    ,tst (-100) 100 0.4 "GAME OVER"
+                                    ,tst (-100) 50 0.2 "n - new level"
+                                    ,tst (-100) 0 0.2 "r - restart"
+                                    ] 
+                                    <> controlsList
+                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+
+hudDrawings :: World -> Picture
+hudDrawings w = (onLayer InvLayer) 
+                        $ displayInv 0 w
+                               <> mconcat
+                          [ dShadCol white $ displayHP 0 w
+                          , dShadCol (itCol (yourItem w)) 
+                                $ drawCursor w, translate (-390) 20 
+                                $ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
+                          ]
+    where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
+
+crDraw :: Creature -> Drawing
+crDraw c = uncurry translateDrawing (_crPos c) $ rotateDrawing (- radToDeg (_crDir c)) (_crPict c c)
+ppDraw :: PressPlate -> Drawing
+ppDraw c = uncurry translateDrawing (_ppPos c) $ rotateDrawing (- radToDeg (_ppRot c)) (_ppPict c)
+btDraw :: Button -> Drawing
+btDraw c = uncurry translateDrawing (_btPos c) $ rotateDrawing (- radToDeg (_btRot c)) (_btPict c)
+
+clDraw :: Cloud -> Drawing
+clDraw c = uncurry translateDrawing (_clPos c) $ (_clPict c c)
+
+drawCursor :: World -> Picture
+drawCursor w = translate (105-halfWidth w) 
+                         (halfHeight w - (25* (fromIntegral iPos)) - 20
+                         )
+                -- $ rectangleWire 200 25
+                 $ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
+    where iPos = _crInvSel $ _creatures w IM.! _yourID w
+
+
+controlsList = mconcat [tst (-250) (-130) 0.15 "controls:"
+               ,tst (-150) (-130) 0.15 "wasd"
+               ,tst  0   (-130) 0.15 "movement"
+               ,tst (-150) (-160) 0.15 "[rmb]"
+               ,tst  0     (-160) 0.15 "aim"
+               ,tst (-150) (-190) 0.15 "[rmb+lmb]"
+               ,tst  0     (-190) 0.15 "shoot or use item"
+               ,tst (-150) (-220) 0.15 "[wheelscroll]"
+               ,tst  0     (-220) 0.15 "select item"
+               ,tst (-150) (-250) 0.15 "[space]"
+               ,tst 0      (-250) 0.15 "pickup item"
+               ,tst (-150) (-280) 0.15 "f"
+               ,tst 0      (-280) 0.15 "drop item"
+               ,tst (-150) (-310) 0.15 "cp[esc]"
+               ,tst 0      (-310) 0.15 "pause"
+               ,tst (-150) (-340) 0.15 "qe[lmb]"
+               ,tst 0      (-340) 0.15 "rotate camera"
+               ]
+                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+
+screenBox w = [  (halfWidth w, halfHeight w)
+              , (-halfWidth w, halfHeight w)
+              , (-halfWidth w,-halfHeight w)
+              , ( halfWidth w,-halfHeight w)
+              ]
+
+mapWall :: Wall -> Maybe Picture
+mapWall wl =
+    case _wlSeen wl of
+        False -> Nothing
+        True -> Just $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
+    where t = 5 *.* errorNormalizeV 68 (y -.- x)
+          n = vNormal t
+          n2 = 4 *.* n
+          (x:y:_) = _wlLine wl
+          c = _wlColor wl
+
+wallsToDraw :: World -> [Wall]
+wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
+    where onScreen wall = lineOnScreen w (_wlLine wall)
+          isVisible wl | wl ^? blVisible == Just False = False
+                       | otherwise = onScreen wl
+
+wallsOnScreen :: World -> IM.IntMap Wall
+wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
+
+drawSmokeShadow :: World -> Smoke -> Drawing
+drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t}) 
+    = (
+        onLayerL [74,0] $ color col $
+                             pictures [uncurry translate p $ circle r'
+                                     ,line $ (\(x,y) -> [x,y]) $ smokePerpLine (_cameraPos w) p sm
+                                     ,line [_cameraPos w, mouseWorldPos w]
+                                     ,trap' p
+                                     ]
+        )
+        <>
+       (onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
+               $ concatMap (f . (+.+ p)) p's
+       ) 
+    where
+        r = r'/2
+        col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red
+            | otherwise = green
+        orth p' = r *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w)
+        pa p' = p' +.+ orth p'
+        pb p' = p' -.- orth p'
+        pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w)
+        pbo p' = pb p' +.+ l *.* safeNormalizeV (pb p' -.- _cameraCenter w)
+        semiCirc p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r
+        a p' = pi - argV (orth p')
+        trap p' = polygon [pa p', pb p', pbo p', pao p']
+        f p' = [semiCirc p', trap p']
+        p's = zipWith (\x p -> rotateV (x * fromIntegral t / 60) p) xs ps
+        xs = concat $ repeat [-1,-0.5,0,0.5,1]
+        l = _windowX w + _windowY w + magV (_cameraPos w -.- _cameraCenter w)
+--        cenpic = color (withAlpha 0.5 c) $ pictures $ f p
+        orth' p' = r' *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w)
+        pa' p' = p' +.+ orth' p'
+        pb' p' = p' -.- orth' p'
+        pao' p' = pa' p' +.+ l *.* safeNormalizeV (pa' p' -.- _cameraCenter w)
+        pbo' p' = pb' p' +.+ l *.* safeNormalizeV (pb' p' -.- _cameraCenter w)
+        trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p']
+        semiCirc' p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r'
+        
+
+drawWall :: Wall -> Drawing
+drawWall wl = case _wlDraw wl of
+        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
+        Just d -> d wl
+    where 
+        (x:y:_) = _wlLine wl
+        c = _wlColor wl
+        t = 5 *.* errorNormalizeVDR (y -.- x)
+        n = vNormal t
+        n2 = 3 *.* n
+        layer2 | _wlIsSeeThrough wl = 0
+               | isJust $ wl ^? doorMech = 1
+               | otherwise = 2
+--          wallOrdering wl = (not $ _wlIsSeeThrough wl, not $ isJust $ wl ^? doorMech)
+
+errorNormalizeVDR :: Point2 -> Point2
+errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
+errorNormalizeVDR p = normalizeV p
+
+printPoint :: Point2 -> Picture
+printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
+
+printRotPoint :: Float -> Point2 -> Picture
+printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3 
+                                                              , rotate r $ scale 0.1 0.1 $ text (show p)]
+
+outsideScreenPolygon :: World -> [Point2]
+outsideScreenPolygon w = [tr,tl,bl,br]
+    where scRot  = rotateV (_cameraRot w)
+          scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
+          scTran p = p +.+ _cameraPos w
+          tr = scTran $ scRot $ scZoom (  3*halfWidth w  , 3* halfHeight w) 
+          tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w) 
+          br = scTran $ scRot $ scZoom (   3*halfWidth w ,- (3* halfHeight w))
+          bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
+          x = halfWidth w + halfHeight w
+
+--  wallShadowsToDrawOnScreen :: World -> [Wall]
+--  wallShadowsToDrawOnScreen w = --IM.elems $ _walls w
+--          sortBy (compare `on` not . _wlIsSeeThrough) $ filter isVisible $ IM.elems 
+--                                                                  $ _walls w
+--  --                                                              $ wallsOnScreen w
+--  -- should really sort this out
+--      where onScreen wall = lineOnScreen w (_wlLine wall)
+--            isVisible wl | wl ^? blVisible == Just False = False
+--                         | otherwise = onScreen wl
+
+wallShadowsToDraw :: World -> [Wall]
+wallShadowsToDraw w = --IM.elems $ _walls w
+        filter isVisible $ IM.elems -- $ _walls w
+                                     $ wallsNearZones (zoneOfSight w) w
+-- should really sort this out
+    where onScreen wall = True -- lineOnScreenCone w (_wlLine wall)
+          isVisible wl | wl ^? blVisible == Just False = False
+                       | otherwise = onScreen wl
+
+-- cannot only test if walls are on screen, but also if they are on the cone
+-- towards the center of sight
+lineOnScreenCone :: World -> [Point2] -> Bool
+lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp 
+                                                || any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
+    where sp' = screenPolygon w
+          vp = _cameraCenter w
+          sp | pointInPolygon vp sp' = sp'
+             | otherwise = orderPolygon $ (_cameraCenter w : sp')
+          sps = zip sp (tail sp ++ [head sp])
+
+
+lineOnScreen :: World -> [Point2] -> Bool
+lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp 
+                                                || any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
+    where sp = screenPolygon w
+          sps = zip sp (tail sp ++ [head sp])
+
+
+drawWallShadow :: World -> Wall -> Drawing
+drawWallShadow w wall
+    | isRHS sightFrom x y = blank
+    | otherwise = onLayerL l $ color shadCol $ polygon $ points
+    where 
+        l | _wlIsSeeThrough wall = [levLayer ShadowLayer]
+          | otherwise            = [levLayer ShadowLayer, 0]
+        (x:y:_) = _wlLine wall 
+        ps = linePointsBetween x y
+        ds = map (\p -> safeNormalizeV (p -.- sightFrom)) ps
+        p's = zipWith (\d x -> (15 *.* d) +.+ x) ds ps
+        sightFrom = _cameraCenter w
+        shadCol = if _wlIsSeeThrough wall then withAlpha 0.2 $ _wlColor wall
+                                              else black
+        corns = screenPolygon w
+        borders = filter g $ zip corns (tail corns ++ [head corns])
+        g (a,b) = isLHS a b sightFrom
+        borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners
+        coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders
+        shadowedCorners = filter isShadowed coneTop
+        isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p
+        f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
+        f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
+        points = orderPolygon (borderps ++ p's)
+
+linePointsBetween :: Point2 -> Point2 -> [Point2]
+linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n-1] ++ [p']
+                       | otherwise = [p,p']
+    where d = dist p p'
+          n = ceiling $ d / 50
+          p'' = (1/fromIntegral n) *.* (p' -.- p)
+
+displayInv :: Int -> World -> Picture
+displayInv n w = mconcat $ zipWith (translate (10-halfWidth w)) 
+                         (map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is
+     where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
+
+dItem' NoItem = scale 0.15 0.15 $ dShadCol (greyN 0.5) $ text "----"
+dItem' i = scale 0.15 0.15 $ pictures [dropShadow t, color (_itInvColor i) t]
+    where t = text $ _itInvDisplay i i
+
+displayAmount :: Int -> String
+displayAmount n | n > 1 = "-x" ++show n
+                | otherwise = []
+
+rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
+
+drawItem :: FloorItem -> Drawing
+drawItem (FlAm {_flItPos = p}) = uncurry translateDrawing p $ onLayer FlItLayer $ rectangleSolid 5 5
+drawItem flIt = uncurry translateDrawing (_flItPos flIt) 
+                    $ rotateDrawing (radToDeg $ _flItRot flIt)  (_itFloorPict (_flIt flIt))
+
+drawButText :: World -> Button -> Picture
+drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100
+                        && hasLOS (_btPos bt) (_crPos (you w)) w
+                        && _btState bt /= BtNoLabel
+                                = t $ rotate (radToDeg (-_cameraRot w))
+                                    $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
+                                                 , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
+                                                 ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white 
+                                                 $ scale 0.1 0.1 $ text $ _btText bt
+                                                 ]
+                 | otherwise = blank
+    where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
+          zoom = _cameraZoom w
+          scLine = dShadCol white . line . fmap (sqrt zoom *.*)
+
+drawPPText :: World -> PressPlate -> Picture
+drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100
+                        && hasLOS (_ppPos pp) (_crPos (you w)) w
+                                = t $ rotate (radToDeg (-_cameraRot w))
+                                    $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
+                                                 , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
+                                                 ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white 
+                                                 $ scale 0.1 0.1 $ text $ _ppText pp
+                                                 ]
+                    | otherwise = blank
+    where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_ppPos pp -.- _cameraPos w))
+          zoom = _cameraZoom w
+          scLine = dShadCol white . line . fmap (sqrt zoom *.*)
+
+drawItemName :: World -> FloorItem -> Picture
+drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
+                        && hasLOS (_flItPos flIt) (_crPos (you w)) w
+                                = t $ rotate (radToDeg (-_cameraRot w))
+                                    $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
+                                                 , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
+                                                 ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white 
+                                                 $ scale 0.1 0.1 $ text $ nameOfItem
+                                                 ]
+                    | otherwise = blank
+    where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w))
+          nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt
+                                    FlAm {_flAm = PistolBullet} -> "Bullets"
+                                    FlAm {_flAm = LiquidFuel} -> "Liquid Fuel"
+          zoom = _cameraZoom w
+          scLine = dShadCol white . line . fmap (sqrt zoom *.*)
+
+ringPict :: Drawing
+ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
+                                     ,line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
+                                     ]
+
+dShadCol :: Color -> Picture -> Picture
+dShadCol c p = pictures $
+                map (flip (uncurry translate) p) [(0.2,-0.2)
+                                                 ,(0.4,-0.4)
+                                                 ,(0.6,-0.6)
+                                                 ,(0.8,-0.8)
+                                                 ,(  1,-  1)
+                                                 ,(1.2,-1.2)
+                                                 ] ++ [color c p]
+
+dropShadow :: Picture -> Picture
+dropShadow p = pictures [ translate 5 (-5) p
+                        , translate 1 (-1) p
+                        , translate 2 (-2) p
+                        , translate 3 (-3) p
+                        , translate 4 (-4) p
+                        , translate 6 (-6) p
+                        , translate 7 (-7) p
+                        , translate 8 (-8) p
+                        , translate 9 (-9) p
+                        ]
+
+ffToDraw :: World -> [ForceField]
+ffToDraw w = filter (lineOnScreen w . _ffLine) $
+                IM.elems $ fmap (over ffLine (map (\p->p -.- _cameraPos w))) $ 
+                _forceFields w
+
+drawFF :: ForceField -> Picture
+drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col 
+                                                        $ lineOfThickness 6 l ]
+
+
+drawFFShadow :: World -> ForceField -> [Picture]
+drawFFShadow w ff
+    | youOnFF   = []
+    | otherwise = map (rotate (radToDeg (- _cameraRot w)) . pane)
+                      [0,0.05..0.25]
+    where p = rotateV (-_cameraRot w) $ ypShift
+          x = rotateV (-_cameraRot w) x'
+          y = rotateV (-_cameraRot w) y'
+          yp = _crPos $ you w
+          (x1:y1:_) = _ffLine ff
+          (x':y':_) | isRHS x1 y1 yp = (y1:x1:[])
+                    | otherwise      = (x1:y1:[])
+          fCol = color (_ffColor ff)
+          col = _ffColor ff
+          ypShift = yp -.- _cameraPos w
+          youOnFF = circOnLine' x' y' ypShift (_crRad $ you w)
+          pane j = color (withAlpha 0.1 col) 
+                    $ polygon
+                    $ [ x
+                      , x +.+ ((0.1 + j) *.* (x -.- ypShift))
+                      , y +.+ ((0.1 + j) *.* (y -.- ypShift))
+                      , y]
+
+displayHP :: Int -> World -> Picture
+displayHP n w = translate (halfWidth w-70) (halfHeight w-40) $
+                    scale 0.2 0.2 $ text $ show
+                    $ _crHP $ _creatures w IM.! n
+
+testPic w = blank
+
+wallsForGloom :: World -> [(Point2,Point2)]
+wallsForGloom w = map (\(x:y:_) -> (screenShift x,screenShift y)) $
+                    map _wlLine $ filter (not . _wlIsSeeThrough) 
+                                $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
+    where screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w)
+          zoom = _cameraZoom w
+
+
+lightsForGloom :: World -> [(Point2,Float,Float)]
+lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
+    where getLS ls = (screenShift $ _lsPos ls, _lsRad ls * zoom, _lsIntensity ls)
+          getTLS ls = (screenShift $ _tlsPos ls, _tlsRad ls * zoom, _tlsIntensity ls)
+          screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w)
+          zoom = _cameraZoom w

src/Dodge/Rooms.hs

@@ -0,0 +1,874 @@
+module Dodge.Rooms where
+-- imports {{{
+import Dodge.Data
+import Dodge.Weapons
+import Dodge.Critters
+import Dodge.LevelGen
+import Dodge.Base
+import Dodge.RandomHelp
+import Dodge.Prototypes
+import Dodge.Path
+import Dodge.Layout
+import Dodge.LightSources
+import Dodge.SoundLogic
+
+import Geometry
+import Picture
+
+import qualified SDL.Mixer as Mix
+
+import Control.Monad.State
+import Control.Monad.Loops
+import Control.Lens
+import System.Random
+
+import Data.List
+import Data.Maybe
+import Data.Tree
+import Data.Either
+import Data.Function
+import qualified Data.Map as M
+
+import Data.Graph.Inductive.Graph hiding ((&))
+import Data.Graph.Inductive.Basic
+import Data.Graph.Inductive.PatriciaTree
+import Data.Graph.Inductive.NodeMap
+
+import qualified Data.IntMap.Strict as IM
+-- }}}
+
+
+
+lev1 :: RandomGen g => State g (Tree Room)
+lev1 = do
+    firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
+    iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) 
+            $ sequence $ treePost 
+            (
+--            [randomiseLinks =<< pistolerRoom] 
+            [return $ return $ Right deadEndRoom
+            ]
+            ++ [return $ connectRoom corridor
+               ,return $ connectRoom door]
+--            ++ [randomiseLinks =<< longRoom]
+            ++ [randomiseLinks =<< pistolerRoom]
+--            ++ [randomiseLinks =<< shooterRoom]
+            ++ [return $ connectRoom door]
+ --           ++ [return $ connectRoom $ set rmPS [PS (100,100) 0 $ PutCrit explosiveBarrel 
+ --                                               ,PS (105,110) 0 $ PutCrit explosiveBarrel
+ --                                               ,PS (115,110) 0 $ PutCrit autoCrit
+ --                                               ,PS (135,110) 0 $ PutCrit explosiveBarrel
+ --                                               ,PS (105,140) 0 $ PutCrit explosiveBarrel
+ --                                               ]
+ --                                    $ roomRect 300 300]
+             ++ [randomiseLinks =<< shooterRoom]
+             ++ (replicate 3 $ randomiseLinks corridor)
+            ++ [return $ connectRoom corridor]
+--            ++ [randomiseLinks =<< longRoom]
+            ++ [return $ connectRoom corridor]
+            ++ firstWeapon
+             ++ (replicate 3 $ randomiseLinks corridor)
+            ++ [return $ connectRoom corridor]
+            ++[return $ connectRoom corridor,return $ connectRoom door]
+            ++ [shootingRange]
+               ++ (replicate 3 $ randomiseLinks corridor)
+              ++[roomMiniIntro]
+               ++ (replicate 3 $ randomiseLinks corridor)
+              ++ [return $ connectRoom corridor
+                 ,return $ connectRoom door
+                 ,slowDoorRoom]
+            ++ [return $ connectRoom corridor
+               ,spawnerRoom
+               ,return $ connectRoom corridor
+               ]
+            )
+            $ randomiseLinks corridor
+
+
+
+
+generateLevel :: Int -> World -> World
+generateLevel i w = 
+    do haltSound $ ((generateFromTree $ levelTree i) w)
+
+levelTree :: Int -> State StdGen (Tree Room)
+levelTree 1 = lev1
+
+levelPortalAt :: Point2 -> Int -> PressPlate
+levelPortalAt p x 
+    = PressPlate
+        { _ppPict = onLayer PressPlateLayer $ color blue $ circle 10
+        , _ppPos = p
+        , _ppRot = 0
+        , _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10
+                                then generateLevel x w
+                                else w
+        , _ppID = -1
+        , _ppText = "Portal to level "++ show x
+        }
+
+airlockOneWay :: Int -> Room
+airlockOneWay n = Room
+    { _rmPolys = [rectNSWE 90 0 0 40]
+    , _rmLinks = lnks
+    , _rmPath  = []
+    , _rmPS    = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (0,40)
+                 ,PS (0,75) 0 $ PutTriggerDoor col (cond)       (0,0) (0,40)
+                 ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState 
+                                                                 (M.insert (DoorNumOpen n) True))
+                 ]
+    --, _rmBound = rectNSWE 90 30 (-30) 30
+    , _rmBound = rectNSWE 75 15 0 40
+    }
+    where lnks = [((0,85),0)
+                 ,((0, 5),pi)
+                 ]
+          cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
+          col = dim $ dim $ bright red
+airlock :: Int -> Room
+airlock n = Room
+    { _rmPolys = [rectNSWE 90 0 0 40]
+    , _rmLinks = lnks
+    , _rmPath  = [((20,85),(20,45))
+                 ,((20,45),(20, 5))
+                 ]
+    , _rmPS    = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (40,0)
+                 ,PS (0,75) 0 $ PutTriggerDoor col (cond)       (0,0) (40,0)
+                 ,PS (35,45) (pi/2) $ PutButton $ makeSwitch col 
+                                    (over worldState (M.insert (DoorNumOpen n) True))
+                                    (over worldState (M.insert (DoorNumOpen n) False))
+                 ]
+    , _rmBound = rectNSWE 75 15 0 40
+    }
+    where lnks = [((20,85),0)
+                 ,((20, 5),pi)
+                 ]
+          cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
+          col = dim $ dim $ bright red
+corridor :: Room
+corridor = Room
+    { _rmPolys = [rectNSWE 80 0 0 40
+                 ,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
+                 ,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap (doublePair . (,) (20,60)) $ map fst lnks
+    , _rmPS    = []
+    , _rmBound = rectNSWE 50 30 0 40
+    }
+    where lnks = [((20,70)  ,0)
+                 ,((20,80) +.+ rotateV (0-pi/3) (-20,0),  pi/6)
+                 ,((20,80) +.+ rotateV (  pi/3) ( 20,0),0-pi/6)
+--                 ,((40,0) +.+ rotateV (  pi/3) (-20,0),  2*pi/3)
+--                 ,(( 0,0) +.+ rotateV (0-pi/3) ( 20,0),0-2*pi/3)
+                 ,((20,10)    ,pi)
+                 ]
+corridorN :: Room
+corridorN = Room
+    { _rmPolys = [rectNSWE 80 0 0 40
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = pth
+    , _rmPS    = []
+    , _rmBound = rectNSWE 50 30 0 40
+    }
+    where lnks = [((20,70)  ,0)
+                 ,((20,10)    ,pi)
+                 ]
+          pth = doublePair ((20,70),(20,10))
+tEast :: Room
+tEast = Room
+    { _rmPolys = [rectNSWE 80 0  (-20) (20)
+                 ,rectNSWE 80 40 (-40) 40
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap (doublePair . (,) (0,60)) $ map fst lnks
+    , _rmPS    = []
+    , _rmBound = rectNSWE 70 10 0 40
+    }
+    where lnks = [(( 30,60),-pi/2)
+                 ,((-30,60),pi/2)
+                 ,((0,10),pi)
+                 ]
+tWest :: Room
+tWest = Room
+    { _rmPolys = [rectNSWE 80 0  (-20) (20)
+                 ,rectNSWE 80 40 (-40) 40
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap (doublePair . (,) (0,60)) $ map fst lnks
+    , _rmPS    = []
+    , _rmBound = rectNSWE 70 10 0 40
+    }
+    where lnks = [((-30,60),pi/2)
+                 ,(( 30,60),-pi/2)
+                 ,((0,10),pi)
+                 ]
+roomC :: Float -> Float -> Room
+roomC x y = Room
+    { _rmPolys = [rectNSWE y 0 0 x]
+    , _rmLinks = lnks
+    , _rmPath  = []
+    , _rmPS    = [PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
+                 ]
+    --, _rmBound = rectNSWE y 0 0 x
+    , _rmBound = []
+    }
+    where lnks = [( (x-20, 0),pi)
+                 ,( (  20, 0),pi)
+                 ,( (  0, 20),pi/2)
+                 ]
+
+makeRect :: Float -> Float -> [(Point2,Point2)]
+makeRect x y = [((0,0),(x,0))
+               ,((0,0),(0,y))
+               ,((x,y),(x,0))
+               ,((x,y),(0,y))
+               ]
+
+gridPoints :: Float -> Int -> Float -> Int -> [Point2]
+gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
+                              , b <- take ny $ scanl (+) 0 $ repeat y
+                       ]
+
+makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
+makeGrid x nx y ny = nub $ concatMap doublePair 
+                         $ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
+                         $ gridPoints x nx y ny
+
+roomPadCut :: [Point2] -> Point2 -> Room
+roomPadCut ps p = Room
+    { _rmPolys = [ps]
+    , _rmLinks = [(p,0),((0,0),pi)]
+    , _rmPath  = [((0,0),p)]
+    , _rmPS    = []
+    , _rmBound = []
+    }
+
+roomRect' :: Float -> Float -> Int -> Int -> Room
+roomRect' x y a b = Room
+    { _rmPolys = [rectNSWE  y 0 0 x ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap doublePair pth
+    , _rmPS    = [PS (x/2,y/2) 0 $ basicLS]
+    , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
+    }
+    where yn,xn :: Int
+          yn = b
+          yd = (y - 40) / fromIntegral yn
+          xn = a
+          xd = (x - 40) / fromIntegral xn
+          elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints  0  1      yd (yn+1)
+          wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints  0  1      yd (yn+1)
+          nlnks = flip zip (repeat (    0)) $ translateS (20,y) $ gridPoints xd (xn+1)  0  1
+          slnks = flip zip (repeat (   pi)) $ translateS (20,0) $ gridPoints xd (xn+1)  0  1
+          lnks = nlnks ++ elnks ++ wlnks ++ slnks
+          pth  = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
+
+roomRect :: Float -> Float -> Room
+roomRect x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
+
+linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
+linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
+    where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)
+
+door :: Room
+door = Room
+    { _rmPolys = [rectNSWE 30 0 0 40]
+    , _rmLinks = lnks
+    , _rmPath  = [((20,25),(20,5))]
+    , _rmPS    = [PS (0,15) 0 $ PutAutoDoor (0,0) (40,0)]
+    , _rmBound = [] 
+    }
+    where lnks = [((20,25),0)
+                 ,((20, 5),pi)
+                 ]
+roomPillars :: Room
+roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect' 240 240 2 2
+    where plmnts = g 180 150 90 60
+          f a x b y = putBlockRect a x b y
+               --  putWallBlocks (a,b) (a,y)
+               --     ++ putWallBlocks (a,y) (x,y)
+               --     ++ putWallBlocks (x,y) (x,b)
+               --     ++ putWallBlocks (x,b) (a,b)
+          g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
+
+
+putBlockRect a x b y =  putWallBlocks (a,b) (a,y)
+                        ++ putWallBlocks (a,y) (x,y)
+                        ++ putWallBlocks (x,y) (x,b)
+                        ++ putWallBlocks (x,b) (a,b)
+putBlockV a x b y = putWallBlocks (a,b) (a,y)
+                        ++ putWallBlocks (x,b) (a,b)
+putBlockC a x b y = putWallBlocks (a,b) (a,y)
+                        ++ putWallBlocks (x,b) (a,b)
+                        ++ putWallBlocks (a,y) (x,y)
+putBlockN a x b y = putWallBlocks (a,b) (a,y)
+                        ++ putWallBlocks (x,b) (a,b)
+                        ++ putWallBlocks (x,y) (x,b)
+
+branchWith :: Room -> [Tree Room] -> Tree (Either Room Room)
+branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts
+
+glassSwitchBack :: RandomGen g => State g Room
+glassSwitchBack = do
+        wth <- state $ randomR (200,400)
+        hgt <- state $ randomR (400,600)
+        wllen <- state $ randomR (60,wth/2-40)
+        let hf = hgt/5
+        let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60,     hf) (wllen,hf)
+                     ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,2*hf) (60,   2*hf)
+                     ,PS (0,0) 0 $ PutWindowBlock (wth-60,   3*hf) (wllen,3*hf)
+                     ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,4*hf) (60,   4*hf)
+                     ]
+                     ++ putWallBlocks (        0, 1*hf) (wllen,1*hf)
+                     ++ putWallBlocks (wth-wllen, 2*hf) (  wth,2*hf)
+                     ++ putWallBlocks (        0, 3*hf) (wllen,3*hf)
+                     ++ putWallBlocks (wth-wllen, 4*hf) (  wth,4*hf)
+        return $ set rmPS plmnts $ roomRect' wth hgt 2 6
+
+manyDoors :: Int -> Tree (Either Room Room)
+manyDoors i = treePost (replicate i (Left door)) $ Right door
+
+glassLesson :: RandomGen g => State g (Tree (Either Room Room))
+glassLesson = do
+    corridors <- sequence $ replicate 3 $ fmap Left $ randLinks corridor
+    return $ Node (Left $ botRoom) [deadRoom door,uppers, treePost (Left door : corridors) $ Right door]
+        where uppers = Node (Left door) [deadRoom topRoom]
+              botRoom = set rmPS botplmnts 
+                                 $ roomRect' 200 200 1 1
+              topRoom = set rmPS topplmnts 
+                                 $ roomRect' 200 200 1 1
+              botplmnts = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110)) 
+                                      $ withAlpha 0.5 aquamarine
+                          ,PS (50,100) 0 $ PutCrit miniGunCrit
+                          ]
+              topplmnts = [PS (0,0) 0 $ PutWindowBlock (100,200) (100,0) 
+                          ,PS (50,100) 0 $ PutCrit miniGunCrit
+                          ]
+
+miniRoom1 :: RandomGen g => State g Room
+miniRoom1 = do
+        wth <- state $ randomR (200,400)
+        hgt <- state $ randomR (400,600)
+        wllen <- state $ randomR (60,wth/2-40)
+        let hf = hgt/5
+        cry <- randomRanges [--50+2*hf,30+3*hf
+                            50+3*hf,30+4*hf
+                            ,50+4*hf,30+5*hf
+                            ]
+        crx <- state $ randomR (wllen,wth-(wllen+40))
+        let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60,     40+hf) (wllen,40+hf)
+                     ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+2*hf) (60,40+2*hf)
+                     ,PS (0,0) 0 $ PutWindowBlock (wth-60,   40+3*hf) (wllen,40+3*hf)
+                     ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+4*hf) (60,40+4*hf)
+                     ,PS (crx,cry) 0 $ PutCrit miniGunCrit
+                     ,PS (wth-20,hgt/2+40) 0 $ randC
+                     ]
+                     ++ putWallBlocks (        0, 40+1*hf) (wllen,40+1*hf)
+                     ++ putWallBlocks (wth-wllen, 40+2*hf) (  wth,40+2*hf)
+                     ++ putWallBlocks (        0, 40+3*hf) (wllen,40+3*hf)
+                     ++ putWallBlocks (wth-wllen, 40+4*hf) (  wth,40+4*hf)
+        return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect' wth hgt 2 4
+
+miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
+miniTree2 = miniRoom1 >>= randLinks >>= changeLinkTo (\p -> (snd . fst) p < 70) 
+                         >>= return . flip branchWith (replicate 3 $ treePost [door,corridor] 
+                                                                              critInDeadEnd   )
+
+miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
+miniRoom3 = do
+        w <- state $ randomR (300,400)
+        h <- state $ randomR (300,400)
+        let l = -70
+        let r = 70
+        let cp = (0,h/2+40)
+        let f = rot90Around cp
+        let f2 = f . f
+        let f3 = f . f .f
+        let cpa p = p +.+ cp
+        let bl = putWallBlocks (cpa (-20,-40)) (cpa (-20,-80))
+        let br = putWallBlocks (cpa (20,-40))  (cpa (20,-80))
+        let bm = putWallBlocks (cpa (25,-35))  (cpa (35,-25))
+        let b = PutBlock [5,20,20] (greyN 0.5) [(-10,-60) 
+                                               ,( 10,-60) 
+                                               ,( 10,-80) 
+                                               ,(-10,-80) 
+                                               ]
+        let plmnts = [PS cp 0 $ PutCrit miniGunCrit
+                     ,PS cp 0 $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (1*pi/4) $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (2*pi/4) $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (3*pi/4) $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (4*pi/4) $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (5*pi/4) $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (6*pi/4) $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (7*pi/4) $ PutWindowBlock (0,-40) (0,-80)
+                     ,PS cp (pi/8)  b
+                     ,PS cp (pi/8+1*pi/4) b
+                     ,PS cp (pi/8+2*pi/4) b
+                     ,PS cp (pi/8+3*pi/4) b
+                     ,PS cp (pi/8+4*pi/4) b
+                     ,PS cp (pi/8+5*pi/4) b
+                     ,PS cp (pi/8+6*pi/4) b
+                     ,PS cp (pi/8+7*pi/4) b
+                     ]
+        randomiseLinks $ set rmPS plmnts $ roomRect w h
+
+rot90Around :: Point2 -> Point2 -> Point2
+rot90Around cen p = cen +.+ vNormal (p -.- cen)
+
+-- So, the idea is to attach outer children to the bottommost right nodes
+-- inside an inner tree
+roomMiniIntro :: RandomGen g => State g (Tree (Either Room Room))
+roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
+                  [return $ connectRoom door
+                  ,join $ takeOne [miniTree2,glassLesson]
+--                  ,join $ takeOne [miniRoom1]
+                  ]
+                  $ randomiseLinks corridor
+    where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
+          f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
+          g (Node (Right x) []) = Node (Right x) []
+          g (Node (Right x) xs) = Node (Left x) $ map g xs
+          g (Node y ys) = Node y $ map g ys
+
+
+putWallBlocks :: Point2 -> Point2 -> [PlacementSpot]
+putWallBlocks a b = map (\p -> PS p rot $ PutBlock [5,20,20] (greyN 0.5) 
+                                            $ reverse $ rectNSWE 10 (-10) (-10) 10)
+                        ps
+    where d = dist a b
+          rot = argV (b -.- a)
+          numPoints' = floor (d / 20)
+          numPoints = numPoints'*2 + 1
+          ns = take (numPoints + 1) [0..]
+          ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) 
+                   $ map fromIntegral ns
+        
+roomCenterPillar :: RandomGen g => State g Room
+roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst) 
+                        $ set rmPS plmnts $ roomRect' 240 240 2 2
+    where plmnts = putWallBlocks (110,110) (110,130)
+                    ++ putWallBlocks (130,110) (130,130)
+
+roomOctogon :: Room
+roomOctogon = Room
+    { _rmPolys = [[(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = allPairs $ map fst lnks
+    , _rmPS    = []
+    , _rmBound = [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] 
+    }
+    where lnks = [((0,140),0)
+                 ,((35,125),0-pi/4)
+                 ,((-35,125),pi/4)
+                 ,( (50,90),0-pi/2)
+                 ,( (-50,90),pi/2)
+                 ,((35,55),0-3*pi/4)
+                 ,((-35,55),3*pi/4)
+                 ,( (0,40),pi)
+                 ]
+
+randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
+randomCorridorFrom xs = do
+    rooms <- sequence $ replicate 5 $ takeOne xs
+    return $ treeTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
+
+
+
+--splitWall :: Float -> Wall -> [[Point]]
+--splitWall x wl = 
+
+sWalls g = wallsFromTree $ evalState (iterateWhile boundClip lev1) $ g
+
+
+randFirstWeapon :: State StdGen PSType
+randFirstWeapon = do
+    r <- state $ randomR (-pi,pi)
+    takeOne $ map PutFlIt 
+                                    [ basicFlIt {_flItRot=r,_flIt = pistol}
+                                    , basicFlIt {_flItRot=r,_flIt = ltAutoGun}
+--                                    , basicFlIt {_flItRot=r,_flIt = autoGun}
+                                    , basicFlIt {_flItRot=r,_flIt = spreadGun}
+                                    , basicFlIt {_flItRot=r,_flIt = multGun}
+                                    , basicFlIt {_flItRot=r,_flIt = launcher}
+--                                    , basicFlIt {_flItRot=r,_flIt = lasGun}
+--                                    , basicFlIt {_flItRot=r,_flIt = flamer}
+                                    ]
+
+--randC1 :: State StdGen PSType
+randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
+
+randC = randC1
+
+-- randSwarmCrit = RandPS $ takeOne $ map PutCrit $ (armouredSwarmCrit : replicate 100 swarmCrit)
+
+weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room))
+weaponEmptyRoom = do
+    w <- state $ randomR (220,300)
+    h <- state $ randomR (220,300)
+    let plmnts = [PS (w/2,h-40) 0 $ RandPS randFirstWeapon
+                 ,PS (20,20) (pi/2) $ randC1
+                 ,PS (w-20,20) (pi/2) $ randC1
+                 ]
+    randomiseLinks =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst) 
+                        $ set rmPS plmnts $ roomRect' w h 2 2)
+     
+
+--weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
+--weaponUnderCrits = do
+--      let plmnts = [PS (0,0)  0 $ RandPS randFirstWeapon
+--                   ,PS (-5,0) (0-pi/2) $ randC1
+--                   ,PS (5,20) (0-pi/2) $ randC1
+--                   ]
+--      let continuationRoom = treeTrunk [Left corridorN,Left corridorN] 
+--                                       (connectRoom (set rmPS plmnts $ corridorN))
+--      deadEndRoom <- takeOne [roomSquare,roomPillars,roomVs,roomCenterPillar]
+--      junctionRoom <- takeOne [Left corridorE,Left corridorW]
+--      return $ treeTrunk [Left corridorN,Left corridorN] 
+--                         $ Node junctionRoom
+--                                [continuationRoom
+--                                ,deadRoom deadEndRoom
+--                                ]
+
+
+weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room))
+weaponBehindPillar  = do
+      crPos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)]
+      let d p = argV $ (120,80) -.- p
+      let plmnts1 = [PS (120,160)  0 $ RandPS randFirstWeapon
+                    ,PS crPos (d crPos) $ randC1
+                    ]
+      rcp <- roomCenterPillar
+      return $ treeTrunk [Left door
+                         ,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp]
+                         (connectRoom $ set rmPS [PS (20,60) (0-pi/2) $ randC1]
+                                                  $ corridorN)
+
+weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
+weaponBetweenPillars = do
+      wpPos <- takeOne [(x,y) | x <- [20,120,220], y <- [20,120,220]]
+      (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [20,220], y <- [20,120,220]])
+      let crPos1 = ps !! 0 
+      let crPos2 = ps !! 1
+      let d p = argV $ (120,120) -.- p
+      let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon
+                   ,PS crPos1 (d crPos1) $ randC1
+                   ,PS crPos2 (d crPos2) $ randC1
+                   ]
+      randomiseLinks =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
+    where f (_,a) = a == 0
+
+blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
+blockedCorridor = do
+    r <- state $ randomR (0,pi)
+    n <- state $ randomR (0,3)
+    let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256) 
+                                          $ reverse $ rectNSWE 10 (-10) (-10) 10
+                 ]
+    sequence $ treePost (replicate n $ fmap Left $ randLinks corridor) 
+                        $ fmap Right $ return $ set rmPS plmnts corridor
+
+-- weaponBehindV :: RandomGen g => State g (Tree (Either Room Room))
+-- weaponBehindV = do
+--       wpPos <- takeOne [(x,y) | x <- [70,-70], y <- [90,230]]
+--       (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [60,-60], y <- [100,220]])
+--       r <- state $ randomR (0,pi)
+--       let crPos1 = ps !! 0 
+--       let crPos2 = ps !! 1
+--       let d p = argV $ (0,160) -.- p
+--       let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon
+--                    ,PS crPos1 (d crPos1) $ randC1
+--                    ,PS crPos2 (d crPos2) $ randC1
+--                    ,PS (0,295) r $ PutBlock [5,5,5] (makeColorI 150 75 0 250) 
+--                                             $ reverse $ rectNSWE 10 (-10) (-10) 10
+--                    ]
+--       return $ connectRoom $ set rmPS plmnts $ roomVs
+
+weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
+weaponLongCorridor = do
+    root <- takeOne $ [tEast, tWest]
+    connectingRoom <- takeOne [tEast,tWest]
+    i1 <- state $ randomR (2,5)
+    i2 <- state $ randomR (2,5)
+    let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom)
+    let branch2 = treeTrunk (replicate i2 $ Left corridor) (deadRoom $ putWp corridorN)
+    return $ Node (Left root) [branch1,branch2]
+        where putCrs = set rmPS  [PS (10,40) (-pi/2) $ randC
+                                   ,PS (-10,40) (-pi/2) $ randC
+                                   ]
+              putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon]
+
+critInDeadEnd :: Room
+critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom
+
+deadEndRoom :: Room
+deadEndRoom = Room
+    { _rmPolys = [rectNSWE 40 (-20) (-20) 20
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = []
+    , _rmPS    = []
+    , _rmBound = rectNSWE 20 (-20) (-30) 30
+    }
+    where lnks = [((0,30)  ,0)
+                 ]
+
+
+weaponRoom :: RandomGen g => State g (Tree (Either Room Room))
+weaponRoom = do
+    x <- takeOne [weaponEmptyRoom
+                 --, weaponUnderCrits
+                 , weaponBehindPillar
+                 , weaponBetweenPillars
+                 , weaponLongCorridor
+                 ]
+    x
+
+roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
+roomCCrits = do
+    ps <- sequence $ replicate 25 $ randInCirc 9
+    let plmnts = map (\p -> PS p 0 $ randC) 
+                       $ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
+    return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200
+
+-- 
+-- roomSwarm :: RandomGen g => State g (Tree (Either Room Room))
+-- roomSwarm = do
+--     ps <- sequence $ replicate 25 $ randInCirc 200
+--     let plmnts = map (\p -> PS ((500,500) +.+ p) 0 $ PutCrit swarmCrit) ps
+--     return $ connectRoom $ set rmPS plmnts $ roomRect 1000 1000
+--     
+
+
+roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
+roomToLevel2 = join $ takeOne
+    [ portalRoom1
+    ]
+
+portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
+portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts}
+    where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
+                   ,PS (60,100) pi $ PutCrit autoCrit
+                   ]
+
+
+
+branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) ->  State g (Tree (Either Room Room))
+branchRectWith t = do
+    x <- state $ randomR (100,200)
+    y <- state $ randomR (100,200)
+    b <- t
+    root <- randLinks $ roomRect x y
+    return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeTrunk [Left door] b]
+        where rToL :: Either a a -> Either a a
+              rToL (Right r) = Left r
+              rToL (Left r)  = Left r
+
+slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
+slowDoorRoom = do
+     x <- state $ randomR (400,800)
+     y <- state $ randomR (400,800)
+     h <- state $ randomR (200,min (y-100) 500)
+     (butPos,butRot) <- takeOne [( (x/2-50,5),0)
+                                ,( (x/2+50,5),0)
+                                ]
+     let n = 25
+     xs <- sequence $ replicate n $ state $ randomR (10,x-10)
+     ys <- sequence $ replicate n $ state $ randomR (h+20,y)
+     rs <- sequence $ replicate n $ state $ randomR (0,2*pi)
+     let ps = zip xs ys
+     xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
+     ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
+     let crits = zipWith (\p r -> PS p r randC1) ps rs
+     let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
+     let pillarsa = []
+     let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
+     let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
+                   ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
+     pillars <- takeOne [pillarsa, pillarsb, pillarsc]
+     let cond x = (snd . fst) x > h + 40
+     let cond2 x = (snd . fst) x < h - 40
+     but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
+                  --  ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
+                    ]
+     fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
+                                             $ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels) 
+                                             $ roomRect x y
+                                             ))
+longRoom :: RandomGen g => State g Room
+longRoom = do
+    h <- state $ randomR (1500,1500)
+    let w = 75
+    let cond x = (snd . fst) x < h - 40
+    -- let solidBlocks = putWallBlocks (12.5,h-25) (12.5,h-265)
+    --                    ++putWallBlocks (37.5,h-25) (37.5,h-265)
+    --                    ++putWallBlocks (62.5,h-25) (62.5,h-265)
+    --                    ++putWallBlocks (87.5,h-25) (87.5,h-265)
+    -- let wBlocks = [PS (0,0) 0 $ PutWindowBlock (12.5,h-50) (12.5,h-265)
+    --               ,PS (0,0) 0 $ PutWindowBlock (37.5,h-50) (37.5,h-265)
+    --               ,PS (0,0) 0 $ PutWindowBlock (62.5,h-50) (62.5,h-265)
+    --               ,PS (0,0) 0 $ PutWindowBlock (87.5,h-50) (87.5,h-265)
+    --               ]
+    let ws = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
+                    [rectNSWE (h-35) (h-135) (-10) 10
+                    ,rectNSWE (h-35) (h-135) 15 35
+                    ,rectNSWE (h-35) (h-135) 40 60
+                    ,rectNSWE (h-35) (h-135) 65 85
+                    ]
+    let wsDefense = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
+                    [rectNSWE (95) (70)  0 25
+                    ,rectNSWE (95) (70) 50 75
+                    ]
+    brls <- fmap (map (\p -> PS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
+                            $ sequence $ replicate 5 $ randInRect (w-20) 900
+    let rm = roomRect' w (h+70) 1 1 & rmPolys %~ ( (++) 
+                                                   [rectNSWE h (h-165) (-45) (w+45)
+                                                   ]
+                                                 )
+    changeLinkTo cond $ set rmPS (ws ++ brls ++ wsDefense ++
+                                 [PS ( 12.5,h-25) 0 $ PutCrit longCrit
+                                 ,PS ( 37.5,h-25) 0 $ PutCrit longCrit
+                                 ,PS ( 62.5,h-25) 0 $ PutCrit longCrit
+                                 ]
+                                 )
+                      $ rm
+
+
+shooterRoom :: RandomGen g => State g Room
+shooterRoom = do
+    h <- state $ randomR (200,300)
+    let cond x = (snd . fst) x < h - 40
+    changeLinkTo cond $ set rmPS ( putWallBlocks (50,50) (50,h) ++
+                                   [PS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit
+                                   ,PS ( 75,h-30) 0 $ PutCrit explosiveBarrel
+                                   ,PS ( 75,h-60) 0 $ PutCrit explosiveBarrel
+                                   ,PS ( 85,h-10) 0 $ PutCrit explosiveBarrel
+                                   ,PS ( 85,h-45) 0 $ PutCrit explosiveBarrel
+                                   ]
+                                 ) 
+                      $ roomRect' 100 h 1 1
+                      
+
+shootersRoom1 :: RandomGen g => State g Room
+shootersRoom1 = do
+    w <- state $ randomR (200,300)
+    x1 <- state $ randomR (20,w/3-20)
+    x2 <- state $ randomR (w/3+20,2*w/3-20)
+    x3 <- state $ randomR (2*w/3+20,w-20)
+    y1 <- state $ randomR (250,560)
+    y2 <- state $ randomR (250,560)
+    y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
+    x4 <- state $ randomR (60,w-60)
+    y4 <- state $ randomR (40,180)
+    p <- takeOne [(x1,y1-10),(x2,y2-10),(x3,y3-10)]
+    let bln x y = putBlockN (x+25) (x-25) (y+10) (y)
+    let blv x y = putBlockV (x+25) (x-25) (y+10) (y)
+    let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
+                  ++ [PS p (-pi/2) $ PutCrit autoCrit
+                     ]
+    return $ set rmPS plmnts $ roomRect w 600
+
+shootersRoom :: RandomGen g => State g Room
+shootersRoom = do
+    w <- state $ randomR (200,300)
+    x1 <- state $ randomR (20,w/3-20)
+    x2 <- state $ randomR (w/3+20,2*w/3-20)
+    x3 <- state $ randomR (2*w/3+20,w-20)
+    y1 <- state $ randomR (250,560)
+    y2 <- state $ randomR (250,560)
+    y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
+    x4 <- state $ randomR (60,w-60)
+    y4 <- state $ randomR (40,180)
+    let bln x y = putBlockN (x+25) (x-25) (y+10) (y)
+    let blv x y = putBlockV (x+25) (x-25) (y+10) (y)
+    let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
+                  ++ [PS (x1,y1-10) (-pi/2) $ PutCrit autoCrit
+                     ,PS (x2,y2-10) (-pi/2) $ PutCrit autoCrit
+                     ,PS (x3,y3-10) (-pi/2) $ PutCrit autoCrit
+                     ]
+    return $ set rmPS plmnts $ roomRect w 600
+
+pistolerRoom :: RandomGen g => State g Room
+pistolerRoom = do
+    let f2 x y = putWallBlocks (x,y) (x,y)
+--    let f2 x y = [PS (x,y) 0 $ PutWindow (rectNSEW 40 0 0 40) $ withAlpha 0.5 aquamarine]
+        f3 x y = putWallBlocks (x-20,y) (x+20,y)
+                        ++ putWallBlocks (x,y-20) (x,y+20)
+        f4 x y = putWallBlocks (x-20,y-20) (x+20,y+20)
+                        ++ putWallBlocks (x+20,y-20) (x-20,y+20)
+    --f <- takeOne [f2,f3,f4]
+    f <- takeOne [f2]
+    h <- state $ randomR (400,800)
+    let w = h
+    i <- takeOne [2,4,6,8]
+    let j = fromIntegral (i+1)
+    -- the 20+etc here is to correct for the pathfinding grid, which matches up to
+    -- edges based on the size of doors (i.e. the line next to the wall is 20
+    -- away from it)
+        xs = take i [20+0.5*(w-40)/(j-1),20+1.5*(w-40)/(j-1)..]
+        ys = take i [20+0.5*(h-40)/(j-1),20+1.5*(h-40)/(j-1)..]
+        gap = 0.5 * h / j
+    ps <- takeN 3 $ zip (map (+gap) xs) ys
+    aa <- state $ randomR (0,2*pi)
+    ab <- state $ randomR (0,2*pi)
+    ac <- state $ randomR (0,2*pi)
+    let plmnts = [PS (ps !! 0) aa $ PutCrit pistolCrit
+                 ,PS (ps !! 1) ab $ PutCrit pistolCrit
+                 ,PS (ps !! 2) ac $ PutCrit pistolCrit
+                -- ,PS (w-5,h/2) 0 $ basicLS
+                -- ,PS (5,h/2) 0 $ basicLS
+                -- ,PS (w/2,h-5) 0 $ basicLS
+                -- ,PS (w/2,5) 0 $ basicLS
+    --             ,PS (w-50,h/2) 0 $ basicLS
+    --             ,PS (50,h/2) 0 $ basicLS
+                 ,PS (w/2,h-50) 0 $ basicLS
+                 ,PS (w/2,50) 0 $ basicLS
+                 ,PS (w-5,h-5) 0 $ basicLS
+                 ,PS (5,h-5) 0 $ basicLS
+                 ,PS (w-5,5) 0 $ basicLS
+                 ,PS (5,5) 0 $ basicLS
+                 ,PS (w/2,h/2) 0 $ basicLS
+                 ] 
+                  ++ 
+              --   f (w*0.25) (h*0.5)
+                 concat [f x y | x<-xs,y<-ys]
+    return 
+        $ set rmPS plmnts $ roomRect' w h (max i 2) (max i 2)
+
+shootingRange :: RandomGen g => State g (Tree (Either Room Room))
+shootingRange = do
+    rm1 <- shootersRoom1 >>= changeLinkTo (\((_,y),_) -> y < 40)
+                        >>= filterLinks  (\((_,y),r) -> y > 200 && r /= 0)
+    rm2 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
+                        >>= filterLinks  (\((_,y),r) -> y > 200 && r /= 0)
+    rm3 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
+                        >>= filterLinks  (\(_,r) -> r == 0)
+    return $ treePost [Left rm1
+                      ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
+                      ,Left rm2
+                      ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
+                      ] 
+                      (Right rm3)
+    
+
+spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
+spawnerRoom = do
+        x <- state $ randomR (250,300)
+        y <- state $ randomR (300,400)
+        wl <- takeOne [PS (0,0) 0 $ PutWindow (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) 
+                                  $ withAlpha 0.5 aquamarine
+                      ,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
+                      ]
+        let plmnts = [PS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit
+                  --   ,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
+                     ,wl
+                     ]
+        let f ((lx,_),_) = lx < x/2-5 
+        roomWithSpawner <- randomiseLinks =<< (filterLinks f $ set rmPS plmnts $ roomRect' x y 2 2) 
+        return $ treeTrunk [Left (airlock 0)] roomWithSpawner

src/Dodge/Smoke.hs

@@ -0,0 +1,33 @@
+module Dodge.Smoke where
+
+import Dodge.Data
+import Dodge.Base
+import Dodge.RandomHelp
+import Geometry.Data
+import Picture
+
+import Control.Lens
+import Control.Monad.State
+
+spawnSmokeAt :: Point2 -> World -> World
+spawnSmokeAt p w =
+    w & smoke %~ (:) thesmoke
+      & randGen .~ g
+    where
+        thesmoke = Smoke 
+                        {_smPos = p
+                        ,_smRad = 20
+                        ,_smColor = white
+                        ,_smUpdate = f
+                        ,_smPs = ps
+                        ,_smTime = 500
+                        }
+        f s = case s ^. smPs of
+                [] -> Nothing
+                _  -> case s ^. smTime of
+                        0 -> Just $ s & smPs %~ init
+                        t -> Just $ s & smTime .~ t-1
+        (ps,g) = runState (sequence $ replicate 60 $ randInCirc 20) $ _randGen w
+
+spawnSmokeAtCursor :: World -> World
+spawnSmokeAtCursor w = spawnSmokeAt (mouseWorldPos w) w

src/Dodge/SoundLogic.hs

@@ -0,0 +1,86 @@
+module Dodge.SoundLogic where
+-- imports {{{
+import Dodge.Data
+
+import Control.Lens
+import qualified Data.Map as M
+-- }}}
+--
+-- PLACEHOLDERS:
+
+haltSound :: World -> World
+haltSound w = w
+
+pauseSound :: World -> World
+pauseSound w = w
+
+resumeSound :: World -> World
+resumeSound w = w
+
+soundOnce :: Int -> World -> World
+soundOnce i = over soundQueue ((:) i)
+
+continueSoundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World
+continueSoundFrom so sType time fadeTime w
+    = over sounds (M.insertWith f so sound) w
+        where sound = Sound { _soundType = sType
+                            , _soundTime = time
+                            , _soundFadeTime = fadeTime
+                            , _soundChannel = Nothing
+                            , _soundPos = Nothing
+                            }
+              f _ s = s {_soundTime = time, _soundFadeTime = fadeTime}
+
+soundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World
+soundFrom so sType time fadeTime w
+    = over sounds (M.insertWith f so sound) w
+        where sound = Sound { _soundType = sType
+                            , _soundTime = time
+                            , _soundFadeTime = fadeTime
+                            , _soundChannel = Nothing
+                            , _soundPos = Nothing
+                            }
+              f _ s = s {_soundTime = time, _soundFadeTime = fadeTime}
+
+soundMultiFrom :: [SoundOrigin] -> Int -> Int -> Int -> World -> World
+soundMultiFrom [] _ _ _ w = w
+soundMultiFrom (so:sos) sType time fadeTime w
+    | so `M.member` _sounds w = soundMultiFrom sos sType time fadeTime w
+    | otherwise = over sounds (M.insert so sound) w
+        where sound = Sound { _soundType = sType
+                            , _soundTime = time
+                            , _soundFadeTime = fadeTime
+                            , _soundChannel = Nothing
+                            , _soundPos = Nothing
+                            }
+
+stopSoundFrom :: SoundOrigin -> World -> World
+stopSoundFrom so = over (sounds . ix so . soundTime) (min 0)
+
+
+-- idea: pass the id of the sound to the world and send it to some queue for
+-- playback
+
+reloadSound,putDownSound,pickUpSound,fireSound,grenadeBang,healSound,teleSound,twoStepSlowSound :: Int
+clickSound = 1
+reloadSound = 2
+pickUpSound  = 4
+putDownSound = 5
+fireSound    = 6
+grenadeBang = 7
+tapQuiet = 8
+twoStepSound = 9
+healSound = 10
+doorSound = 11
+twoStepSlowSound = 12
+knifeSound = 13
+buzzSound = 14
+hitSound = 15
+autoGunSound = 16
+shotgunSound = 17
+teleSound = 18
+longGunSound = 19
+launcherSound = 20
+smokeTrailSound = 21
+foot1Sound = 22
+foot2Sound = 23

src/Dodge/Update.hs

@@ -0,0 +1,190 @@
+module Dodge.Update where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Dodge.WallCreatureCollisions
+import Dodge.Block
+import Dodge.Camera
+import Dodge.SoundLogic
+
+import Geometry
+
+import Data.List
+import Data.Maybe
+import Data.Function
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+
+import Control.Lens
+
+
+-- }}}
+
+update :: World -> World
+update w = let w1 = updateParticles' $ updateParticles 
+                     $ updateLightSources
+                     $ zoneClouds
+                     $ updateClouds
+                     $ updateSmoke
+                     $ updateCreatures 
+                     $ updateBlocks -- $ zoning 
+                     $ updateSeenWalls 
+                                                     w
+               w2 = -- updateWeaponCounters $
+                 simpleCrSprings 
+                 $ zoneCreatures $ wallEvents
+                 $ set worldEvents id $ _worldEvents w1
+                                 w1
+               w3 = updateCamera
+                           $ updateAfterParticles'
+                           $ colCrsWalls 
+                             w2
+           in  checkEndGame $ ppEvents w3
+    where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
+          --               w
+          -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
+          --                   = insertIMInZone x y wlid wl
+          --               | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
+          --   where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
+          --         wlid  = _wlID wl
+          --         ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
+          zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
+          creatureInZone cr = insertIMInZone x y cid cr
+            where (x,y) = zoneOfPoint $ _crPos cr
+                  cid = _crID cr
+          zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
+          cloudInZone cr = insertIMInZone x y cid cr
+            where (x,y) = zoneOfPoint $ _clPos cr
+                  cid = _clID cr
+
+updateLightSources w = set tempLightSources (catMaybes tlss) w'
+    where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
+
+updateParticles w = IM.foldr' _ptUpdate w $ _particles w
+
+updateSmoke :: World -> World
+updateSmoke w = w & smoke %~ mapMaybe (\s -> _smUpdate s s)
+
+updateParticles' :: World -> World
+updateParticles' w = set particles' (catMaybes ps) w'
+    where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
+
+updateAfterParticles' :: World -> World
+updateAfterParticles' w = set afterParticles' (catMaybes ps) w'
+    where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _afterParticles' w
+
+updateCreatures :: World -> World
+updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
+    where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
+
+
+wallEvents :: World -> World
+wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of 
+                                                                Door {} -> True
+                                                                AutoDoor {} -> True
+                                                                BlockAutoDoor {} -> True
+                                                                _       -> False) ( _walls w))
+
+ppEvents :: World -> World
+ppEvents w = IM.foldr' (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
+
+updateSeenWalls :: World -> World
+updateSeenWalls w = foldr markSeen w wallsToUpdate
+    where yPos = _crPos $ _creatures w IM.! 0
+          wallsToUpdate = map _wlID $ IM.elems $ wallsNearPoint yPos w
+--          wallsToUpdate = concatMap (\p -> collidePointFindWalls yPos (yPos +.+p) $ wallsAlongLine yPos (yPos +.+ p) w)
+--                                   $ nRays 60
+          markSeen i = set (walls . ix i . wlSeen) True
+
+setTestStringIO :: IO World -> IO World
+setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
+    where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
+    -- w --do numC <- Mix.numChannelsPlaying
+--                       w' <- w
+--                       let ycr = _creatures w' IM.! 0
+--                       let st = _stance $ _crState ycr
+--                       let vel = magV $ _crPos ycr -.- _crOldPos ycr
+--                       let (x,y) = zoneOfPoint $ _crPos ycr
+--                       --fmap (set testString $ show (map _wlLine $ IM.elems $ _wallsZone w' IM.! x IM.! y)) w
+--                       fmap (set testString $ show $ last $ show $ pairsToIncidence' $ _pathGraph' w') w
+
+-- update logic: creature old position set, creatures perform actions including movement, 
+-- creatures collided with each other, camera updated, particles updated, creatures
+-- collided with walls
+
+
+checkEndGame :: World -> World
+checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuState = GameOverMenu}
+               | otherwise         = w
+
+updateClouds :: World -> World
+updateClouds w = IM.foldr' updateCloud w $ _clouds w 
+
+updateCloud :: Cloud -> World -> World
+updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
+                | otherwise = moveCloud c w
+
+moveCloud :: Cloud -> World -> World
+moveCloud c w = _clEffect c c . theUpdate $ w
+    where newVel = 0.99 *.* springVels
+          springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w)
+          oldPos = _clPos c
+          newPos = oldPos +.+ newVel
+          hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
+          finalPos = fromMaybe newPos (fmap fst hitWl)
+          finalVel = fromMaybe newVel (fmap snd hitWl)
+          theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
+                            & clouds . ix (_clID c) . clVel .~ finalVel
+                            & clouds . ix (_clID c) . clPos .~ finalPos
+
+clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2
+clClSpringVel a w b v 
+    | ida == idb = v
+    | dist pa pb < 5 = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb))
+    | otherwise = v
+    where ida = _clID a
+          idb = _clID b
+          pa = _clPos a
+          pb = _clPos b
+
+simpleCrSprings :: World -> World
+simpleCrSprings w = IM.foldr' crSpring w $ _creatures w
+
+crSpring :: Creature -> World -> World
+crSpring c w = IM.foldr' (crCrSpring c) w $ cs
+    where cs = creaturesNearPoint (_crPos c) w
+
+crCrSpring :: Creature -> Creature -> World -> World
+crCrSpring c1 c2 w 
+     | id1 == id2 = w
+     | vec == (0,0) = w
+     | diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
+                         $ over (creatures . ix id2 . crPos) (-.- overlap2) w
+     | otherwise = w
+         where id1  = _crID c1
+               id2  = _crID c2
+               vec  = _crPos c1 -.- _crPos c2
+               diff = magV $ vec
+               comRad  = _crRad c1 + _crRad c2
+               overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
+               overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
+               massT    = _crMass c1 + _crMass c2
+
+collidePointFindWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Int
+collidePointFindWall p1 p2 ws = fmap fst $ listToMaybe $ sortBy f 
+                                            $ IM.toList 
+                                            $ IM.mapMaybe ((\(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
+    where f (_,a) (_,b) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+
+collidePointFindWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
+collidePointFindWalls p1 p2 ws 
+    -- = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fst . fromJust)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
+    = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fromJust . fst)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
+    where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
+          g (_,wl) = _wlIsSeeThrough wl
+          takeWhileAnd h xs = let (ys,zs) = span h xs
+                              in  ys ++ tf zs
+                where tf (x:_) = [x]
+                      tf _ = []
+          

src/Dodge/WallCreatureCollisions.hs

@@ -0,0 +1,95 @@
+module Dodge.WallCreatureCollisions where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Geometry
+
+import Data.List
+import Data.Maybe
+import Data.Function
+import Control.Lens
+import qualified Data.IntMap.Strict as IM
+
+colCrsWalls :: World -> World
+colCrsWalls w = over creatures (fmap (colCrWall w)) w
+
+colCrWall :: World -> Creature -> Creature
+colCrWall w c = pushOutFromWall w c
+
+pushOutFromWall :: World -> Creature -> Creature
+pushOutFromWall w c 
+    | p1 == p2 = c
+    | otherwise = over crPos ( 
+                              collideCorners rad p1 wallPoints
+                             . 
+                               collideWalls rad p1 ls 
+                             . checkPushThroughs rad p1 ls 
+                             ) 
+                       c 
+    where rad = _crRad c + wallBuffer
+          p1  = _crOldPos c
+          p2  = _crPos c
+          ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
+          wallPoints = nub $ concat ls
+
+-- colCrPushThrough :: World -> Creature -> Creature
+-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
+--     where rad = _crRad cr + wallBuffer
+--           p1  = _crOldPos cr
+--           p2  = _crPos cr
+--           ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
+-- -- probably best to push check pushing through walls before creature springs
+
+-- the amount to push creatures out from walls, extra to their radius
+wallBuffer = 3
+
+-- the following tests whether a moving circle crosses a list of walls, and
+-- places the circle accordingly.
+-- It supposes that the circle will only interact with at most two walls.
+-- the reverse prevents the collision from happening again with the first wall,
+-- when two walls are collided with
+collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
+collideWalls rad cp1 walls cp2
+    = case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of
+            Nothing -> cp2
+            Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of
+                                         Nothing -> cp3
+                                         Just cp4 -> cp4
+
+-- assumes that the wall is orientated
+-- assumes wall points are different
+collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
+collideWall rad cp1 cp2 (wp1:wp2:_) 
+            | isOnWall  = Just newP -- +.+ (1 *.* norm))
+            | otherwise = Nothing
+    where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
+          wp1' = (rad *.* norm) +.+ wp1
+          wp2' = (rad *.* norm) +.+ wp2
+          newP = errorClosestPointOnLine 5 wp1' wp2' cp2
+          isOnWall = circOnLine' wp1 wp2 cp2 rad
+          isJust Nothing = False
+          isJust _       = True
+
+collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
+collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps
+
+-- collide circles with points (outer corners)
+intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
+intersectCirclePoint rad p cCen | dist cCen p > rad = cCen
+                                | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
+
+checkPushThroughs :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
+checkPushThroughs rad cp1 walls cp2
+    = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls
+
+checkPushThrough :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
+checkPushThrough  rad cp1 cp2 (wp1:wp2:_) 
+            | isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
+            | otherwise = Nothing
+    where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
+          wp1' = (rad *.* norm) +.+ wp1
+          wp2' = (rad *.* norm) +.+ wp2
+          newP = errorClosestPointOnLine 5 wp1' wp2' cp2
+          isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
+          isJust Nothing = False
+          isJust _       = True

src/Dodge/WorldActions.hs

@@ -0,0 +1,901 @@
+module Dodge.WorldActions where
+
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+import Dodge.RandomHelp
+import Geometry
+import Picture
+
+import Control.Lens
+import Control.Monad.State
+
+import System.Random
+
+import Data.Maybe
+import Data.Function
+import Data.List
+import qualified Data.IntMap.Strict as IM
+
+makeExplosionAt :: Point2 -> World -> World
+makeExplosionAt p w = soundOnce grenadeBang 
+                        $ over tempLightSources ((:) $ tLightFade 20 150 intensityF p)
+                        $ fs 
+                        $ over particles (IM.insert n exp) 
+                            w
+    where n = newParticleKey w
+          exp = Particle
+                { _ptPos = p
+                , _ptStartPos = p
+                , _ptVel = (0,0)
+                , _ptPict = blank
+                , _ptID = n
+                , _ptUpdate = explosionWaveDamage 6 p n
+                }
+          fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w
+          fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w
+          fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) 
+          --fPs = map (pushAgainstWalls . (+.+) p . (*.*) 5) 
+                    fPs'
+          inversePushOut v = (15 - magV v) * 0.01 *.* v
+          fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
+          sizes = randomRs (2,6) $ _randGen w
+          times = randomRs (20,25) $ _randGen w
+          mF q v size time = makeFlameletTimed q v (levLayer GloomLayer - 1) Nothing size time
+          newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
+          fs w = foldr ($) w newFs
+          pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y) 
+                                           $ collidePointWalls p q $ wallsNearPoint q w
+          fadeFac x | x > 10 = 0
+                    | otherwise = 1 - fromIntegral x / 10
+          intensityF x | x < 10 = 1 / (10 - fromIntegral x)
+                       | otherwise = 1
+
+explosionWaveDamage :: Int -> Point2 -> Int -> World -> World
+explosionWaveDamage 0 p ptid = over particles (IM.delete ptid)
+explosionWaveDamage time p ptid 
+    = set (particles . ix ptid . ptUpdate) (explosionWaveDamage (time-1) p ptid)
+      . shockWaveDamage p rad 20
+        . set (particles . ix ptid . ptPict) shockwavePic
+        . lowLightRadAt white 0.3 75 150 p
+    where shockwavePic = onLayer PtLayer $ uncurry translate p $ color (withAlpha 0.9 white) 
+                                                               $ thickCircle rad (thickness*2)
+          thickness = max 0 $ sqrt $ (fromIntegral time - 2) * 8
+          rad = 40 - thickness
+
+shockWaveDamage :: Point2 -> Float -> Int -> World -> World
+shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w
+    where f cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage) 
+                                                             ((:) $ Concussive amount p 2 0.5 rad) cr
+               | otherwise                            = cr
+          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+          damageBlocks wall w
+            = case wall ^? blHP of 
+                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - (div amount 2))) 
+                                 w 
+                                 (_blIDs wall)
+                _ -> w
+
+makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color
+                 -> World -> World
+makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave)
+    where theShockwave = shockwaveAt p rad dam push col 10
+
+shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
+shockwaveAt p rad dam push col maxtime
+    = Shockwave'
+            { _ptPict'      = blank
+            , _ptUpdate'    = mvShockwave'
+            , _btColor'     = col
+            , _btPos'       = p
+            , _btRad'       = rad
+            , _btDam'       = dam
+            , _btPush'      = push
+            , _btMaxTime'   = maxtime
+            , _btTimer'     = maxtime
+            }
+
+mvShockwave' :: World -> Particle' -> (World, Maybe Particle')
+mvShockwave' w pt 
+    | _btTimer' pt <= 0 = (w, Nothing)
+    | otherwise
+        = (dams w , Just $ set btTimer' (t - 1) $ set ptPict' pic pt)
+    where r    = _btRad' pt
+          p    = _btPos' pt
+          push = _btPush' pt
+          dam  = _btDam' pt
+          t    = _btTimer' pt
+          tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
+          pic = onLayer PtLayer $ uncurry translate p 
+                                $ color (_btColor' pt) $ thickCircle rad thickness
+          rad = r - (3/4) * r * tFraction
+          thickness = tFraction**2 * r 
+          dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
+          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+          damageBlocks wall w
+            = case wall ^? blHP of 
+                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
+                                 w 
+                                 (_blIDs wall)
+                _ -> w
+          damCr cr | dist (_crPos cr) p < rad + _crRad cr 
+                                = over (crState . crDamage) 
+                                       ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p)))
+                                       cr
+                   | otherwise  = cr
+moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
+moveShockWave 0 _ _ _    _       w _  = (w, Nothing)
+moveShockWave t p r push pushexp w pt 
+    = (dams w, Just $ newupdate $ newpic pt )
+    where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp
+          newpic = set ptPict' (onLayer PtLayer $ uncurry translate p 
+                                $ color cyan $ thickCircle rad thickness)
+          rad = r - (3/40) * r * fromIntegral t
+          thickness = (fromIntegral t)**2 * rad / 40
+          dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
+          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+          damageBlocks wall w
+            = case wall ^? blHP of 
+                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
+                                 w 
+                                 (_blIDs wall)
+                _ -> w
+          damCr cr | dist (_crPos cr) p < rad + _crRad cr 
+                                = over (crState . crDamage) 
+                                       ((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p)))
+                                       cr
+                   | otherwise  = cr
+
+inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
+inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
+    where theShockwave 
+            = Particle' 
+                { _ptPict' = blank
+                , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
+                }
+moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
+moveInverseShockWave 0 _ _ _    _       w _  = (w, Nothing)
+moveInverseShockWave t p r push pushexp w pt 
+    = (dams w, Just $ newupdate $ newpic pt )
+    where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
+          newpic = set ptPict' (onLayer PtLayer $ uncurry translate p 
+                                $ color cyan $ thickCircle rad thickness)
+          rad = r - (4/40) * r * fromIntegral (10 - t)
+          thickness = (fromIntegral (10 - t))**2 * rad / 40
+          dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
+          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+          damageBlocks wall w
+            = case wall ^? blHP of 
+                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
+                                 w 
+                                 (_blIDs wall)
+                _ -> w
+          damCr cr | dist (_crPos cr) p < rad + _crRad cr 
+                                = over (crState . crDamage) 
+                                       ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
+                                       cr
+                   | otherwise  = cr
+    
+
+-- makeTremorAt :: Int -> Point -> Float -> Particle
+-- makeTremorAt i pos d = Particle
+--     { _ptPos = (0,0)
+--     , _ptStartPos = (0,0)
+--     , _ptVel = (0,0)
+--     , _ptPict = Line [(0,0),(0,0)]
+--     , _ptID = i
+--     , _ptUpdate = moveTremor [pos] 200 pos d i
+--     }
+-- 
+-- moveTremor :: [Point] -> Int -> Point -> Float -> Int -> World -> World
+-- moveTremor ps t p1 d i w 
+--     | t <= -30  = over particles (IM.delete i) . over partUnder (IM.delete i) $ w
+--     | t <= 0    = set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 d i)
+--                             . over partUnder 
+--                                 (IM.insert i (lineOfThickness (0.1*(fromIntegral t + 30)) ps)) $ w
+--     | otherwise = case hitWall of
+--         Nothing -> upUndPict . set randGen g . shakeCrs . 
+--                             shatterAt p1 pl $ shatterAt p1 pr
+--                             $ set (particles . ix i . ptUpdate) (moveTremor (p3:ps) (t-1) p3 d i) 
+--                             $ damCrsOnLine 10 p1 p3 w
+--         Just (pw,pRef) -> set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 (argV pRef) i) w
+--     where p2 = p1 +.+ 5 *.* unitVectorAtAngle d
+--           pl = p1 +.+ rotateV (d + pi/4) (75,0)
+--           pr = p1 +.+ rotateV (d - pi/4) (75,0)
+--           hitWall = collidePointWalls p1 p3 $ wallsAlongLine p1 p3 w
+--           (d1,g) = randomR (0,2*pi) $ _randGen w
+--           v = unitVectorAtAngle d1
+--           p3 = p2 +.+ 5 *.* v
+--           shakeCrs = over creatures (IM.map shCr)
+--           shCr cr | dist p1 (_crPos cr) < 75 = over crPos (+.+ v) cr
+--                   | otherwise = cr
+--           upUndPict = over partUnder (IM.insert i pic)
+--           pic = pictures [color white $ lineOfThickness 3 [p3,head ps]
+--                          ,lineOfThickness 3 ps]
+-- 
+-- makeTremorAt' :: Int -> Point -> Particle
+-- makeTremorAt' i pos = Particle
+--     { _ptPos = (0,0)
+--     , _ptStartPos = (0,0)
+--     , _ptVel = (0,0)
+--     , _ptPict = Line [(0,0),(0,0)]
+--     , _ptID = i
+--     , _ptUpdate = rotateTremorAround 10 pos i
+--     }
+-- 
+-- rotateTremorAround :: Int -> Point -> Int -> World -> World
+-- rotateTremorAround 0 p i w = over particles (IM.delete i) w
+-- rotateTremorAround t p i w = set (particles . ix i . ptUpdate) (rotateTremorAround (t-1) p i)
+--                              $ foldr ($) w shatters
+--     where rot d = rotateV $ d + fromIntegral t * pi / 7
+--           ds = fmap (\x -> fromIntegral x * pi / 2.5) [0..4]
+--           shatters = map (\d -> shatterAt p (p +.+ rot d (300,0))) ds
+-- 
+-- shatterAt :: Point -> Point -> World -> World
+-- shatterAt p1 p2 w = case wlHit of
+--         Just (p,v,col) -> makeFallingBlock col (f1 p) (f2 v)
+--                            $ set randGen g w
+--         _          -> w
+--     where wlHit = collidePointWallsNormCol p1 p2 $ wallsNearPoint p2 w
+--           f1 q = q +.+ 5 *.* errorNormalizeV 10 (p2 -.- p1)
+--           (d,g) = randomR (-0.5,0.5) $ _randGen w
+--           f2 v' = rotateV d $ 3 *.* errorNormalizeV 11 v'
+-- 
+-- fallingWall :: Int -> Color -> Point -> Float -> Particle
+-- fallingWall pid col p d
+--     = Particle
+--     { _ptPos = p
+--     , _ptStartPos = p
+--     , _ptVel = rotateV d (3,0)
+--     , _ptPict = Line [(0,0),(0,0)]
+--     , _ptID = pid
+--     , _ptUpdate = moveFallingWall 10 p d col pid
+--     }
+-- 
+-- moveFallingWall :: Int -> Point -> Float -> Color -> Int -> World -> World
+-- moveFallingWall 0 p d col i w = over particles (IM.delete i) $ b1 $ b2 w
+--     where b1 = makeFallingBlock col (p +.+ ( 3, 3)) (rotateV d (0,5))
+--           b2 = makeFallingBlock col (p +.+ (-3,-3)) (rotateV d (0,1))
+-- moveFallingWall t p d col i w
+--     = set (particles . ix i . ptUpdate) (moveFallingWall (t-1) np d col i)
+--       $ set (particles . ix i . ptPict) pic
+--         w
+--     where np = p +.+ 1 *.* unitVectorAtAngle d
+--           pic = uncurry translate p $ rotate (-radToDeg d)
+--                 $ color col $ polygon [(-6,-6)
+--                                       ,(-6, 6)
+--                                       ,( 6, 6)
+--                                       ,( 6,-6)
+--                                       ]
+-- 
+-- makeFallingBlock :: Color -> Point -> Point -> World -> World
+-- makeFallingBlock col p v w
+--     = over particles (IM.insert i $ fallingBlock i col p v) w
+--     where i = newParticleKey w
+-- 
+-- fallingBlock :: Int -> Color -> Point -> Point -> Particle
+-- fallingBlock pid col p v
+--     = Particle
+--     { _ptPos = p
+--     , _ptStartPos = p
+--     , _ptVel = v
+--     , _ptPict = Line [(0,0),(0,0)]
+--     , _ptID = pid
+--     , _ptUpdate = moveFallingBlock 10 p v col pid
+--     }
+-- 
+-- moveFallingBlock :: Int -> Point -> Point -> Color -> Int -> World -> World
+-- moveFallingBlock 0 p v col i w = over particles (IM.delete i) w
+-- moveFallingBlock t p v col i w
+--     = case hitCr of
+--         Nothing -> set (particles . ix i . ptUpdate) (moveFallingBlock (t-1) np v col i)
+--             $ set (particles . ix i . ptPict) pic
+--               w
+--         Just (p1,v1,crID) -> over particles (IM.delete i) 
+--             $ over (creatures . ix crID . crHP) (\hp -> hp - 1) w
+--     where np = p +.+ v
+--           pic = uncurry translate p $ rotate (-radToDeg (argV v))
+--                 $ color col $ polygon [(-3,-3)
+--                                       ,(-3, 3)
+--                                       ,( 3, 3)
+--                                       ,( 3,-3)
+--                                       ]
+--           hitCr = reflectCircCreatures 4 p np $ _creatures w
+
+
+-- if the spark is created by another Particle', it cannot be directly added to
+-- the list, hence the redirect through worldEvents
+createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
+createSpark time colid pos dir maycid w = over worldEvents 
+                                        ((.) $ ( over particles' ((:) spark) 
+                                               . flareAt' white 0.02 0.05 pos')
+                                               -- . lowLightAt' pos)
+                                        ) w
+    where spark = Bul'  { _ptPict' = blank
+                        , _ptUpdate' = mvGenBullet'
+                        , _btVel' = rotateV dir (5,0)
+                        , _btColor' = numColor colid
+                        , _btTrail' = [pos]
+                        , _btPassThrough' = maycid
+                        , _btWidth' = 1
+                        , _btTimer' = time
+                        , _btHitEffect' = threeEff' sparkEff noEff noEff
+                        }
+          x = fst $ randomR (0,20) $ _randGen w
+          pos' = pos +.+ rotateV dir (x,0)
+          sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
+                                  ((:) $ SparkDam 1 sp p ep)
+            where sp = head (_btTrail' bt)
+                  ep = sp +.+ _btVel' bt
+
+createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
+createBarrelSpark time colid pos dir maycid w = over worldEvents 
+                                        ((.) $ ( over particles' ((:) spark) 
+                                               . flareAt' white 0.005 0.03 pos')
+                                               -- . lowLightAt' pos)
+                                        ) w
+    where spark = Bul'  { _ptPict' = blank
+                        , _ptUpdate' = mvGenBullet'
+                        , _btVel' = rotateV dir (5,0)
+                        , _btColor' = numColor colid
+                        , _btTrail' = [pos]
+                        , _btPassThrough' = maycid
+                        , _btWidth' = 1
+                        , _btTimer' = time
+                        , _btHitEffect' = threeEff' sparkEff noEff noEff
+                        }
+          x = fst $ randomR (0,20) $ _randGen w
+          pos' = pos +.+ rotateV dir (x,0)
+          sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
+                                  ((:) $ SparkDam 1 sp p ep)
+            where sp = head (_btTrail' bt)
+                  ep = sp +.+ _btVel' bt
+
+flareAt :: Color -> Point2 -> World -> World
+flareAt c p = flareAt' c 0.02 0.5 p
+
+flareAt' :: Color -> Float -> Float -> Point2 -> World -> World
+flareAt' col alphax alphay p 
+    =  over particles' ((:) (flashColAt col alphax p))
+      . lowLightColAt col alphay p
+
+        
+tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
+tLightFade 0 rmax intensityF p =
+    TLS { _tlsPos = p
+        , _tlsRad = rmax
+        , _tlsIntensity = intensityF 0
+        , _tlsUpdate = \w _ -> (w, Nothing)
+        }
+tLightFade i rmax intensityF p =
+    TLS { _tlsPos = p
+        , _tlsRad = rmax
+        , _tlsIntensity = intensityF i
+        , _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
+        }
+
+tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource
+tLightRad 0 rmax rmin p =
+    TLS { _tlsPos = p
+        , _tlsRad = rmax
+        , _tlsIntensity = 0.5
+        , _tlsUpdate = \w _ -> (w, Nothing)
+        }
+tLightRad i rmax rmin p =
+    TLS { _tlsPos = p
+        , _tlsRad = rmax
+        , _tlsIntensity = 0.5
+        , _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
+        }
+
+tLightAt i p = tLightRad i 100 0 p
+
+flareWidth :: Float -> Float -> Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
+flareWidth len wdth rad rays col ax ay p
+    = over particles' ((:) (flashRadAt rad col ax p))
+      . lowLightWidthAt len wdth col ay rays rad p
+
+flareRad :: Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
+flareRad rad rays col ax ay p
+    = over particles' ((:) (flashRadAt rad col ax p))
+      . lowLightRadAt col ay rays rad p
+
+flashRadAt :: Float -> Color -> Float -> Point2 -> Particle'
+flashRadAt rad col alphax (x,y) =
+    Particle' 
+        { _ptPict' = mconcat $
+                         map (\i -> onLayerL [levLayer PtLayer]
+                                        $ color (withAlpha alphax col) $ translate x y $ circleSolid i
+                         )
+                         [rad/5,2*rad/5,3*rad/5,4*rad/5,rad]
+        , _ptUpdate' = ptTimer' 1
+        }
+
+flashColAt :: Color -> Float -> Point2 -> Particle'
+flashColAt col alphax (x,y) =
+    Particle' 
+        { _ptPict' = mconcat $
+                         map (\i -> onLayerL [levLayer PtLayer] 
+                                    $ color (withAlpha alphax col) $ translate x y $ circleSolid i
+                         )
+                         [20,25,30,35,40,45,50]
+        , _ptUpdate' = ptTimer' 1
+        }
+lowLightWidthAt :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> World -> World
+lowLightWidthAt len wdth col alphay rays rad p w = foldr (lowLightWidthHit len wdth col alphay p) w ps
+    where ps = map ((+.+) p) $ nRaysRad rays rad
+
+lowLightRadAt :: Color -> Float -> Int -> Float -> Point2 -> World -> World
+lowLightRadAt col alphay rays rad p w = foldr (lowLightColHit col alphay p) w ps
+    where ps = map ((+.+) p) $ nRaysRad rays rad
+
+lowLightColAt :: Color -> Float ->  Point2 -> World -> World
+lowLightColAt col alphay p w = foldr (lowLightColHit col alphay p) w ps
+    where ps = map ((+.+) p) $ nRaysRad 20 30
+
+lowLightDirected :: Color -> Float -> Point2 -> Point2 -> [Float] -> World -> World
+lowLightDirected col alpha a b angles w
+    = foldr (\angle w' -> lowLightColHit col alpha a (a +.+ rotateV angle b) w') w angles
+
+lowLightColHit :: Color -> Float -> Point2 -> Point2 -> World -> World
+lowLightColHit col alphay a b w 
+    = case thingsHitLongLine a b w of
+        ((p, E3x2 wall):_) 
+            -> over particles' ((:) (wallGlareCol col alphay p wall)) w
+        ((p, E3x1 cr):_) 
+            -> over afterParticles' ((:) (crGlareCol col alphay p cr)) w
+        _  -> w
+
+wallGlareCol :: Color -> Float -> Point2 -> Wall -> Particle'
+wallGlareCol col alphay p wl = wallGlareWidth 10 5 col alphay p wl
+
+crGlareCol :: Color -> Float -> Point2 -> Creature -> Particle'
+crGlareCol col alphay p cr = crGlareWidth 5 col alphay p cr
+
+lowLightWidthHit :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World
+lowLightWidthHit len wdth col alphay a b w 
+    = case thingsHitLongLine a b w of
+        ((p, E3x2 wall):_) 
+            -> over particles' ((:) (wallGlareWidth len wdth col alphay p wall)) w
+        ((p, E3x1 cr):_) 
+            -> over afterParticles' ((:) (crGlareWidth wdth col alphay p cr)) w
+        _  -> w
+
+wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle'
+wallGlareWidth len wdth col alphay p wl = 
+    Particle'
+        { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l
+        , _ptUpdate' = ptTimer' 1
+        }
+    where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x]
+          x = len *.* ( normalizeV $ a -.- b)
+          (a:b:_) = _wlLine wl
+
+crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle'
+crGlareWidth wdth col alphay p cr =
+    Particle'
+        { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp
+        --{ _ptPict' = [(blank, [levLayer WlLayer + 2])]
+        , _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w
+                                              ,_ptUpdate' = ptTimer' 0
+                                              }
+                                )
+        }
+    where l x = uncurry translate x
+                $ rotate (90 - (radToDeg $ argV (p -.- x)))
+                $ color (withAlpha alphay col) 
+                $ thickArc 0 180 (_crRad cr) wdth
+--    where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5
+          cp = _crPos cr
+          cid = _crID cr
+          upp cid' w' = case w' ^? creatures . ix cid . crPos of
+                            Just y -> l y 
+                            --Just p -> uncurry translate p $ circleSolid 5
+                            _      -> blank
+
+muzFlareAt :: Point2 -> World -> World
+muzFlareAt p = over particles' ((:) (muzzleFlareAt p))
+                . lowLightAt p
+
+muzzleFlareAt :: Point2 -> Particle'
+muzzleFlareAt (x,y) =
+    Particle' 
+        { _ptPict' = mconcat 
+                        $ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i
+                         )
+                         [20,25,30,35,40,45,50]
+        , _ptUpdate' = ptTimer' 1
+        }
+
+ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle')
+ptTimer' 0 w pt = (w, Nothing)
+ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)})
+
+lowLightAt :: Point2 -> World -> World
+lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w
+
+lowLightHit :: Point2 -> Point2 -> World -> World
+lowLightHit a b w 
+    = case thingsHitLongLine a b w of
+        ((p, E3x2 wall):_) 
+            -> over particles' ((:) (wallGlare p wall)) w
+        ((p, E3x1 cr):_) 
+            -> over afterParticles' ((:) (crGlare p cr)) w
+        _  -> w
+
+wallGlare :: Point2 -> Wall -> Particle'
+wallGlare p wl = wallGlareWidth 10 5 white 0.5 p wl
+
+crGlare :: Point2 -> Creature -> Particle'
+crGlare = crGlareCol white 0.5
+-- crGlare p cr =
+--     Particle'
+--         { _ptPict' = [(l, [levLayer WlLayer + 2])]
+--         , _ptUpdate' = ptTimer' 1
+--         }
+--     where l = uncurry translate cp 
+--                 $ rotate (90 - (radToDeg $ argV (p -.- cp)))
+--                 $ color (withAlpha 0.5 white) 
+--                 $ thickArc 0 180 (_crRad cr) 5
+-- --    where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5
+--           cp = _crPos cr
+
+
+lowLightAt' :: Point2 -> World -> World
+lowLightAt' p w = foldr (lowLightHit' p) w ps
+    where ps = map ((+.+) p) $ nRaysRad 20 30
+
+lowLightHit' :: Point2 -> Point2 -> World -> World
+lowLightHit' a b w 
+    = case thingsHitLongLine a b w of
+        ((p, E3x2 wall):_) 
+            -> over particles' ((:) (wallGlare' p wall)) w
+        _  -> w
+
+wallGlare' :: Point2 -> Wall -> Particle'
+wallGlare' p wl = wallGlareWidth 5 5 white 0.1 p wl
+
+noEff _ _ _ = id
+
+threeEff' :: 
+    ( Particle' -> Point2 -> Creature   -> World -> World ) ->
+    ( Particle' -> Point2 -> Wall       -> World -> World ) ->
+    ( Particle' -> Point2 -> ForceField -> World -> World ) ->
+     Particle' -> (Point2, Either3 Creature Wall ForceField) -> World -> World
+threeEff' crEff wlEff ffEff pt thing w = case thing of
+    (p,E3x1 cr) -> crEff pt p cr w
+    (p,E3x2 wl) -> wlEff pt p wl w
+    (p,E3x3 ff) -> ffEff pt p ff w
+
+mvGenBullet' :: World -> Particle' -> (World, Maybe Particle')
+mvGenBullet' w bt 
+    | t <= 0 = (w, Nothing)
+    | t < 4  = (w, Just $ set btPassThrough' Nothing
+                        $ set btTrail' (p:p:ps)
+                        $ set ptPict' (bulLine col wth (p:p:ps))
+                        $ set btTimer' (t-1) bt                      
+                )
+    | otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of
+        []  -> (w, Just  $ set btPassThrough' Nothing
+                        $ set btTrail' (p +.+ vel :p:ps)
+                        $ set ptPict' (bulLine col wth (p +.+ vel:p:ps))
+                        $ set btTimer' (t-1) bt                      
+                )
+        ((hitp,thing):_) 
+            -> ( hiteff bt (hitp,thing) w
+               , Just   $ set btPassThrough' Nothing
+                        $ set btTrail' (hitp:p:ps)
+                        $ set ptPict' (bulLine col wth (hitp:p:ps))
+                        $ set btTimer' 3 bt                      
+                )
+  where mcr     = _btPassThrough' bt
+        col     = _btColor' bt
+        (p:ps)  = _btTrail' bt
+        vel     = _btVel' bt
+        hiteff  = _btHitEffect' bt
+        wth     = _btWidth' bt
+        t       = _btTimer' bt
+
+bulLine :: Color -> Float -> [Point2] -> Drawing
+bulLine col width (a:b:[]) 
+    = onLayer HPtLayer $ pictures 
+        [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b]
+        ,color white $ wedgeOfThickness width a b
+--        ,color white $ lineOfThickness width [a,b]
+--        ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b]
+--        ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
+        ]
+--    where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
+--          a3 = (0.3 *.* a) +.+ (0.7 *.* b)
+bulLine col width (a:b:c:_) 
+    = onLayer HPtLayer $ pictures 
+        [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c]
+        ,color white $ wedgeOfThickness width a c
+--        ,color white $ lineOfThickness width [a,b]
+--        ,color (withAlpha 0.3 white) $ lineOfThickness (width-1) [a3,c]
+--        ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
+--        ,color white                 $ lineOfThickness width [a,a2]
+        ]
+--    where a2 = b
+--          a3 = (0.5 *.* b) +.+ (0.5 *.* c)
+--    where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
+--          a3 = (0.3 *.* a) +.+ (0.7 *.* b)
+--bulLine col width (a:b:c:d:_) 
+--    = onLayer HPtLayer $ pictures 
+--                [color (withAlpha 0.5 col) $ lineOfThickness (width+1) [a,c]
+--        ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b]
+--        ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
+--        ,color white                 $ lineOfThickness width [a,a2]
+--        ]
+--    where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
+--          a3 = (0.3 *.* a) +.+ (0.7 *.* b)
+
+thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World 
+                        -> [(Point2, (Either3 Creature Wall ForceField))]
+thingsHitExceptCr Nothing    sp ep = thingsHit sp ep
+thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
+    where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
+          crNotCid _ = True
+
+thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
+thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++  walls ++ ffs)
+    where hitCrs   = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
+                                          $ creaturesAlongLine sp ep w
+          crPs     = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
+          crs   = zip crPs (map E3x1 hitCrs)
+        --  hitWls   = wallsOnLine sp ep (f y $ f x $ _wallsZone w)
+          hitWls   = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
+                                                                            , b<-[y-1,y,y+1]])
+          (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+          walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
+          hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
+          hitFFs   = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
+          ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
+
+thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World 
+                        -> [(Point2, (Either3 Creature Wall ForceField))]
+thingsHitExceptCrLongLine Nothing    sp ep = thingsHitLongLine sp ep
+thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep
+    where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
+          crNotCid _ = True
+
+thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
+--thingsHitLongLine sp ep w = crs ++ walls
+thingsHitLongLine sp ep w = sortBy (compare `on` dist sp . fst) (crs ++  walls ++ ffs)
+    where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
+                                 --       $ _creatures w
+                                          $ creaturesAlongLine sp ep w
+          crPs   = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
+          --crPs     = map _crPos hitCrs
+          crs   = zip crPs (map E3x1 hitCrs)
+        --  hitWls   = wallsOnLine sp ep (f y $ f x $ _wallsZone w)
+          hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
+          --hitWls = wallsOnLine sp ep $ _walls w
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+          --walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
+          walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
+          hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
+--          hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
+          hitFFs   = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
+          ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
+          cr = _creatures w IM.! 0
+
+makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World
+makeFlameletTimed  pos vel levelInt maycid size time w
+    = set randGen g $ over particles' ((:) theFlamelet) 
+        $ flareAt' white 0.01 0.1 pos w
+    where   theFlamelet =
+                Pt' { _ptPict'         = blank
+                     , _ptUpdate'      = moveFlamelet levelInt rot
+                     , _btVel'         = vel
+                     , _btColor'       = red
+                     , _btPos'         = pos
+                     , _btPassThrough' = maycid
+                     , _btWidth'       = size
+                     , _btTimer'       = time
+                     , _btHitEffect'   = threeEff' (doFlameDam 1) noEff noEff
+                     }
+            (rot ,g) = randomR (0,3) $ _randGen w
+
+makeFlamelet :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> World -> World
+makeFlamelet pos vel levelInt maycid size w = set randGen g $ over particles' ((:) theFlamelet) w
+    where   theFlamelet =
+                Pt' { _ptPict'         = blank
+                     , _ptUpdate'      = moveFlamelet levelInt rot
+                     , _btVel'         = vel
+                     , _btColor'       = red
+                     , _btPos'         = pos
+                     , _btPassThrough' = maycid
+                     , _btWidth'       = size
+                     , _btTimer'       = 20
+                     , _btHitEffect'   = threeEff' (doFlameDam 1) noEff noEff
+                     }
+            (rot ,g) = randomR (0.5,1.5) $ _randGen w
+moveFlamelet :: Int -> Float -> World -> Particle' -> (World, Maybe Particle')
+moveFlamelet levelInt rot w pt = 
+    case _btTimer' pt of 
+      time | time <= 0 -> (w, Nothing)
+           | otherwise -> (damcrs, mvPt)
+        where   sp = _btPos' pt
+                vel = _btVel' pt
+                ep = sp +.+ vel
+                size = _btWidth' pt
+                siz2 = size + 0.2
+                mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepicture
+                                 , _btPassThrough' = Nothing
+                                 ,_btVel' = 0.8 *.* vel}
+                damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
+                closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
+                dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
+                                ((:) $ Flaming 3 sp ep ep)
+                pic = onLayerL [levelInt,3] $ uncurry translate ep
+                              $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
+                                                 white                           (dark red)
+                                      )
+                              $ rotate (radToDeg ( 0.1 * fromIntegral time + rot))
+                              $ scale sc sc
+                              $ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
+                piu = onLayerL [levelInt,1] $  uncurry translate ep 
+                           $ color (dark red) $ rotate (radToDeg (rot - 0.1 * fromIntegral time))
+                           $ scale s1 s1
+                           $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
+                glow = onLayerL [levelInt,0] $ uncurry translate ep
+                            $ color (withAlpha 0.01 red)
+                            $ circleSolid 30
+                sc = (*) 2 $ log $ 1 + fromIntegral time / 20
+                s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
+                s2 = 0.5 * (sc + s1)
+                thepicture = pic <> piu <> pi2 <> glow
+                pi2 = onLayerL [levelInt,2] $ uncurry translate ep
+                           $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
+                                              orange                          (dark red)
+                                      )
+                           $ rotate (radToDeg $ rot + 0.2 * fromIntegral time)
+                           $ scale s2 s2
+                           $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
+                
+
+doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World
+doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
+                                 ((:) $ Flaming amount sp p ep)
+        where sp = _btPos' pt
+              ep = sp +.+ _btVel' pt
+
+
+                    
+makeSmokeAt :: Point2 -> World -> World
+makeSmokeAt p w = over particles (IM.insert n smP) w
+    where n = newParticleKey w
+          smP = Particle
+                { _ptPos = p
+                , _ptStartPos = p
+                , _ptVel = (0,0)
+                , _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1
+                --, _ptPict = uncurry translate p $ color white $ circleSolid 30
+                , _ptID = n
+                , _ptUpdate = moveSmoke p 20 n
+                }
+
+moveSmoke :: Point2 -> Int -> Int -> World -> World
+moveSmoke p time i | time > 0 =
+    set (particles . ix i . ptPict) pic . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i)
+                   | time > -50 =
+    set (particles . ix i . ptPict) pi1 . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i)
+                   | otherwise =
+     over particles (IM.delete i)
+
+    where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ 21 - fromIntegral time
+          pi1 = onLayer PtLayer $ uncurry translate p 
+                    $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) 
+                    $ circleSolid $ 21
+
+makeSmokeAt' :: Float -> Int -> Point2 -> World -> World
+makeSmokeAt' scal time p w = over particles (IM.insert n smP) w
+    where n = newParticleKey w
+          smP = Particle
+                { _ptPos = p
+                , _ptStartPos = p
+                , _ptVel = (0,0)
+                , _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1
+                , _ptID = n
+                , _ptUpdate = moveSmoke' scal p time n
+                }
+
+moveSmoke' :: Float -> Point2 -> Int -> Int -> World -> World
+moveSmoke' scal p time i 
+    | time > 0 
+        = set (particles . ix i . ptPict) pic 
+                    . set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i)
+    | time > -50 
+        = set (particles . ix i . ptPict) pi1 
+                    . set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i)
+    | otherwise 
+        = over particles (IM.delete i)
+    where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
+          pi1 = onLayer PtLayer $ uncurry translate p 
+                    $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) 
+                    $ circleSolid $ 21 * scal
+
+makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World
+makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w
+    where smokeP = Particle'
+                     { _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1
+                     , _ptUpdate' = moveSmoke'' scal time p vel
+                     }
+
+moveSmoke'' :: Float -> Int -> Point2 -> Point2 -> World -> Particle' -> (World, Maybe Particle')
+moveSmoke'' scal time p vel w pt
+    | time > 0   = (w, Just $ pt { _ptPict' = pic
+                                 , _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
+                                 })
+    | time > -50 = (w, Just $ pt { _ptPict' = pi1
+                                 , _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
+                                 })
+    | otherwise  = (w, Nothing)
+    where pNew = p +.+ vel
+          pic = onLayerL [levLayer PtLayer - 1] 
+                    $ uncurry translate pNew 
+                    $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
+          pi1 = (onLayerL [levLayer PtLayer]
+                    $ uncurry translate pNew 
+                    $ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5)) 
+                    $ circleSolid $ 21 * scal)
+                <> (onLayerL [levLayer BgLayer+1]
+                    $ uncurry translate pNew 
+                    $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) 
+                    $ circleSolid $ 21 * scal)
+
+makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World
+makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w
+    where n = newParticleKey w
+          smP = Particle
+                { _ptPos = p
+                , _ptStartPos = p
+                , _ptVel = vel
+                , _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 1
+                , _ptID = n
+                , _ptUpdate = moveColorSmoke col scal time n
+                }
+
+moveColorSmoke :: Color -> Float -> Int -> Int -> World -> World
+moveColorSmoke col scal time i w
+    | time > 0 
+        = set (particles . ix i . ptPict) pic 
+            . set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
+            . set (particles . ix i . ptPos) newPos
+            . setVel
+            $ w
+    | time > -50 
+        = set (particles . ix i . ptPict) pi1 
+            . set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
+            . set (particles . ix i . ptPos) newPos
+            . setVel
+            $ w
+    | otherwise 
+        = over particles (IM.delete i) w
+    where oldPos = _ptPos $ _particles w IM.! i
+          newPos = oldPos +.+ (_ptVel $ _particles w IM.! i)
+          setVel = over (particles . ix i . ptVel) $ (*.*) 0.99
+          pic = onLayer PtLayer $ uncurry translate newPos $ color col $ circleSolid $ (21 - fromIntegral time) * scal
+          pi1 = onLayer PtLayer $ uncurry translate newPos 
+                    $ color (withAlpha (1 + fromIntegral time /50) col) 
+                    $ circleSolid $ 21 * scal
+
+
+thingHit :: Point2 -> Maybe (Point2,a,b) -> Maybe (Point2,c) -> Maybe (Either (Point2,a,b) (Point2,c))
+thingHit p Nothing Nothing = Nothing
+thingHit p (Just x) Nothing = Just (Left x)
+thingHit p Nothing (Just x) = Just (Right x)
+thingHit p (Just x@(p1,_,_)) (Just y@(p2,_))
+    | magV (p -.- p1) > magV (p -.- p2) = Just (Right y)
+    | otherwise = Just (Left x)
+
+
+damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World
+damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
+    where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr) 
+                                     = over crHP (\hp -> hp - dam) cr
+                         | otherwise = cr

src/EventHelper.hs

@@ -0,0 +1,11 @@
+module EventHelper where
+import SDL
+
+stripTimestamp :: (world -> EventPayload -> Maybe world)
+                    -> world -> Event -> Maybe world
+stripTimestamp f w e = f w (eventPayload e)
+
+test :: world -> EventPayload -> Maybe world
+test w e = case e of
+    KeyboardEvent (KeyboardEventData _ Pressed _ (Keysym _ KeycodeReturn _)) -> Nothing
+    _ -> Just w

src/Geometry.hs

@@ -0,0 +1,576 @@
+{-# LANGUAGE BangPatterns #-}
+module Geometry
+    ( module Geometry
+    , module Geometry.Data
+    )
+    where
+import Geometry.Data
+
+import Data.Function
+import Data.List
+import Data.Maybe
+
+import Control.Applicative
+
+zeroZ :: Point2 -> Point3
+zeroZ (x,y) = (x,y,0)
+
+infixl 6 +.+, -.-
+infixl 7 *.*
+
+(+.+) :: Point2 -> Point2 -> Point2
+{-# INLINE (+.+) #-}
+(x1, y1) +.+ (x2, y2) =
+  let
+    !x = x1 + x2
+    !y = y1 + y2
+  in (x, y)
+
+(-.-) :: Point2 -> Point2 -> Point2
+{-# INLINE (-.-) #-}
+(x1, y1) -.- (x2, y2) =
+  let
+    !x = x1 - x2
+    !y = y1 - y2
+  in (x, y)
+
+(*.*) :: Float -> Point2 -> Point2
+{-# INLINE (*.*) #-}
+a *.* (x2, y2) =
+  let
+    !x = a * x2
+    !y = a * y2
+  in (x, y)
+
+infixl 6 +.+.+, -.-.-
+infixl 7 *.*.*
+
+(+.+.+) :: Point3 -> Point3 -> Point3
+{-# INLINE (+.+.+) #-}
+(x1, y1, z1) +.+.+ (x2, y2, z2) =
+  let
+    !x = x1 + x2
+    !y = y1 + y2
+    !z = z1 + z2
+  in (x, y, z)
+
+(-.-.-) :: Point3 -> Point3 -> Point3
+{-# INLINE (-.-.-) #-}
+(x1, y1, z1) -.-.- (x2, y2, z2) =
+  let
+    !x = x1 - x2
+    !y = y1 - y2
+    !z = z1 - z2
+  in (x, y, z)
+
+(*.*.*) :: Point3 -> Point3 -> Point3
+{-# INLINE (*.*.*) #-}
+(x1, y1, z1) *.*.* (x2, y2, z2) =
+  let
+    !x = x1 * x2
+    !y = y1 * y2
+    !z = z1 * z2
+  in (x, y, z)
+
+normalizeV :: Point2 -> Point2
+{-# INLINE normalizeV #-}
+normalizeV p = (1 / magV p) *.* p
+
+angleVV :: Point2 -> Point2 -> Float
+{-# INLINE angleVV #-}
+angleVV a b = let ma = magV a
+                  mb = magV b
+                  d  = a `dotV` b
+              in  acos $ d / (ma * mb)
+
+dotV :: Point2 -> Point2 -> Float
+{-# INLINE dotV #-}
+dotV (x,y) (z,w) = x*z + y*w
+
+closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2
+{-# INLINE closestPointOnLine #-}
+closestPointOnLine a b p
+    = a +.+ u *.* (b -.- a)
+    where u = closestPointOnLineParam a b p
+
+closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float
+{-# INLINE closestPointOnLineParam #-}
+closestPointOnLineParam a b p
+    = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
+
+argV :: Point2 -> Float
+{-# INLINE argV #-}
+argV (x,y) = normalizeAngle $ atan2 y x
+
+detV :: Point2 -> Point2 -> Float
+{-# INLINE detV #-}
+detV (x1, y1) (x2, y2)
+       = x1 * y2 - y1 * x2
+
+-- | Angle in radians, anticlockwise from +ve x-axis.
+unitVectorAtAngle :: Float -> Point2
+{-# INLINE unitVectorAtAngle #-}
+unitVectorAtAngle r
+        = (cos r, sin r)
+
+-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise.
+rotateV :: Float -> Point2 -> Point2
+rotateV r (x, y)
+ =      (  x * cos r - y * sin r
+        ,  x * sin r + y * cos r)
+{-# INLINE rotateV #-}
+
+-- | Convert degrees to radians
+degToRad :: Float -> Float
+degToRad d      = d * pi / 180
+{-# INLINE degToRad #-}
+
+
+-- | Convert radians to degrees
+radToDeg :: Float -> Float
+radToDeg r      = r * 180 / pi
+{-# INLINE radToDeg #-}
+
+
+-- | Normalize an angle to be between 0 and 2*pi radians
+normalizeAngle :: Float -> Float
+normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
+ where  floor' :: Float -> Float
+        floor' x = fromIntegral (floor x :: Int)
+{-# INLINE normalizeAngle #-}
+
+-- the following helper draws a rectangle based on maximal N E S W values
+rectNESW :: Float -> Float -> Float -> Float -> [Point2]
+rectNESW a b c d = [(b,a),(b,c),(d,c),(d,a)
+                   ]
+rectNSEW n s e w = rectNESW n e s w
+
+rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
+rectNSWE n s w e = [ (w,n), (w,s), (e,s), (e,n)]
+
+-- -- the following filters points in a polygon: supposes the points in the
+-- polygon are listed in anticlockwise order
+pointInOrOnPolygon :: Point2 -> [Point2] -> Bool
+pointInOrOnPolygon p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x])
+
+
+pointInPolygon :: Point2 -> [Point2] -> Bool
+pointInPolygon p [] = False
+pointInPolygon p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x])
+
+errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
+errorPointInPolygon i p xs | length xs == 1 = error "one point polygon"
+                           | length xs == 2 = error "two point polygon"
+                           | nub xs == xs = pointInPolygon p xs
+                           | otherwise = error $ "errorPointInPolygon "++ show i
+
+errorNormalizeV :: Int -> Point2 -> Point2
+errorNormalizeV i (0,0) = error $ "problem with function: errorNormalizeV "++show i
+errorNormalizeV i p = normalizeV p
+
+errorAngleVV :: Int -> Point2 -> Point2 -> Float
+errorAngleVV i (0,0) _ = error $ "problem with function: errorAngleVV "++show i
+errorAngleVV i _ (0,0) = error $ "problem with function: errorAngleVV "++show i
+errorAngleVV i p p' = angleVV p p'
+
+errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
+errorIsLHS i x y | x == y = error $ "problem with function: errorIsLHS "
+                                                    ++show i
+                 | otherwise = isLHS x y
+
+errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
+errorClosestPointOnLine i x y | x == y = error $ "problem with function: errorClosestPointOnLine "
+                                                    ++show i
+                              | otherwise = closestPointOnLine x y
+
+errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
+errorClosestPointOnLineParam  i x y z | x == y = dist x z
+--    error $ "problem with function: errorClosestPointOnLineParam " ++show i
+                              | otherwise = closestPointOnLineParam  x y z
+
+safeNormalizeV :: Point2 -> Point2
+safeNormalizeV (0,0) = (0,0)
+safeNormalizeV p = normalizeV p
+
+-- tests whether a point is on the LHS of a line
+-- this has been called somewhere with l1 == l2
+isLHS :: Point2 -> Point2 -> Point2 -> Bool
+{-# INLINE isLHS #-}
+isLHS' l1 l2 p | l1 == l2  = False
+              | otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0
+
+isLHS (x,y) (x',y') (x'',y'') 
+    | (x,y) == (x',y')  = False
+    | otherwise = a1 * b2 - a2 * b1 > 0
+    where a1 = x' - x
+          a2 = y' - y
+          b1 = x'' - x
+          b2 = y'' - y
+
+isRHS :: Point2 -> Point2 -> Point2 -> Bool
+{-# INLINE isRHS #-}
+isRHS (x,y) (x',y') (x'',y'') 
+    | (x,y) == (x',y')  = False
+    | otherwise = a1 * b2 - a2 * b1 < 0
+    where a1 = x' - x
+          a2 = y' - y
+          b1 = x'' - x
+          b2 = y'' - y
+--isRHS l1 l2 p = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p > 0
+
+-- reorders points to be anticlockwise around their center
+orderPolygon :: [Point2] -> [Point2]
+orderPolygon [] = []
+orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
+    where cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
+
+vNormal :: Point2 -> Point2
+{-# INLINE vNormal #-}
+vNormal (x,y) = (y,-x)
+
+vInverse :: Point2 -> Point2
+vInverse (x,y) = (-x,-y)
+
+dist :: Point2 -> Point2 -> Float
+{-# INLINE dist #-}
+dist p1 p2 = magV (p2 -.- p1)
+
+normV :: Point2 -> Point2
+{-# INLINE normV #-}
+normV (0,0) = (0,0)
+normV p = (1/magV p ) *.* p
+
+magV :: Point2 -> Float
+{-# INLINE magV #-}
+magV (x,y) = sqrt $ x^2 + y^2
+
+pHalf :: Point2 -> Point2 -> Point2
+pHalf a b = 0.5 *.* (a +.+ b)
+
+linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
+linGrad (x,y) (a,b) | x-a == 0  = Nothing
+                    | otherwise = Just $ (y-b)/(x-a)
+
+axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
+axisInt p (a,b) =  pure b ^-^ (pure a ^*^ linGrad p (a,b))
+    where (^-^) = liftA2 (-)
+          (^*^) = liftA2 (*)
+
+-- intersectSegSeg is sometimes broken-- the following fixes at least some of
+-- the cases
+-- it is, however, slow
+myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of
+        Nothing    -> Nothing
+        Just (x,y) -> if inbetween x && inbetween' y 
+                        then Just (x,y)
+                        else Nothing
+    where inbetween  x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) &&
+                         ((cx <= x && x <= dx) || (dx <= x && x <= cx))
+          inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) &&
+                         ((cy <= y && y <= dy) || (dy <= y && y <= cy))
+
+crossV :: Point2 -> Point2 -> Float
+crossV (ax,ay) (bx,by) = ax*by - ay*bx
+
+myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a)
+myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
+    | linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0))
+    | linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0))
+    | otherwise              
+        = case linGrad a b ^-^ linGrad c d of
+            Just 0 -> Nothing
+            _      -> liftA2 (,) newx
+                                 ((linGrad a b ^*^ newx) ^+^ axisInt a b)
+    where (^-^) = liftA2 (-)
+          (^+^) = liftA2 (+)
+          (^/^) = liftA2 (/)
+          (^*^) = liftA2 (*)
+          newx  = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
+          (*-*) (ax,ay) (bx,by) = (ax-bx,ay-by)
+
+ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
+    where toRatPoint2 (x,y) = (toRational x, toRational y)
+          toNumPoint2 (x,y) = (fromRational x, fromRational y)
+          f = toRatPoint2 . roundPoint2
+
+roundPoint2 :: Point2 -> Point2
+roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)
+
+circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool
+circOnLine' p1 p2 c rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
+    where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
+          isJustTrue (Just True) = True
+          isJustTrue _           = False
+
+circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool
+circOnLine p1 p2 c rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
+                             || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
+    where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
+          isJustTrue (Just True) = True
+          isJustTrue _           = False
+
+difference x y | x > y = x - y
+               | otherwise = y - x
+
+reflectIn :: Point2 -> Point2 -> Point2
+reflectIn line vec = let angle = 2 * angleBetween line vec
+                     in  rotateV angle vec
+
+angleBetween v1 v2 = argV v1 - argV v2
+
+doublePair :: (a,a) -> [(a,a)]
+doublePair (x,y) = [(x,y),(y,x)]
+
+polysIntersect :: [Point2] -> [Point2] -> Bool
+polysIntersect (p:ps) (q:qs) 
+    = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
+    where pairs1 = zip (p:ps) (ps++[p])
+          pairs2 = zip (q:qs) (qs++[q])
+
+anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
+anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
+
+nRays :: Int -> [Point2]
+nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (600,0)
+
+nRaysRad :: Int -> Float -> [Point2]
+nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (x,0)
+
+-- angles go from 0 to 2pi, need to work out what is left of another
+
+isLeftOfA :: Float -> Float -> Bool
+isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2)
+                || (angle2 - angle1 > pi && angle2 > angle1)
+
+isLeftOf :: Point2 -> Point2 -> Bool
+isLeftOf x y = isLeftOfA (argV x) (argV y)
+
+-- diffAngles has an issue...
+
+diffAngles :: Float -> Float -> Float
+diffAngles x y | diff > pi  = diffAngles (x - 2*pi) y
+               | diff >= 0  = diff
+               | diff > -pi = -diff
+               | otherwise  = diffAngles (x + 2*pi) y
+    where diff = x-y
+differenceAngles = diffAngles
+angleDifference = diffAngles
+
+-- given a triangle where we know the length of a first side,
+-- the length of a second side, and the angle between the first side and the
+-- third side, finds the length of the third side
+-- not this doesn't necessarily find ALL solutions, asin is a map not a function
+ssaTri :: Float -> Float -> Float -> Float
+ssaTri ab bc a 
+    | sin a == 0 = 0
+    | bc == 0    = ab
+    | otherwise = let c = asin ( (ab * (sin a))/bc)
+                      b = pi - (a + c)
+                  in  sin b * bc / sin a
+
+-- fix points: we now fix the triangle in the coordinate system, and return a
+-- third unknown point:
+-- the point which lies between pa and pc' on a line from b of length bc
+-- note that there are likely two such points, this seems to return the point
+-- closer to pc'
+
+ssaTriPoint :: Point2 -> Point2 -> Point2 -> Float -> Point2
+ssaTriPoint pa pb pc' bc
+    = let ab = magV (pa -.- pb)
+          a  = errorAngleVV 6 (pb -.- pa) (pc' -.- pa)
+          ac = ssaTri ab bc a
+      in  pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa))
+
+-- the above SHOULD return a Maybe Point...
+ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
+ssaTriPoint' pa pb pc' bc
+    | dist pb (closestPointOnSeg pa pc' pb) >= bc
+        = Nothing
+    | otherwise
+        = Just $ ssaTriPoint pa pb pc' bc
+ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
+ssaTriPointCorrect pa pb pc' bc
+    | param <= 1 && param >= 0 = Just p
+    | otherwise                = Nothing
+    where p = ssaTriPoint pa pb pc' bc
+          param = closestPointOnLineParam pa pc' p
+
+
+closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2
+closestPointOnSeg segP1 segP2 p
+    | errorClosestPointOnLineParam 3 segP1 segP2 p <= 0 = segP1
+    | errorClosestPointOnLineParam 4 segP1 segP2 p >= 1 = segP2
+    | otherwise                                  = errorClosestPointOnLine 2 segP1 segP2 p
+
+pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
+pointInCircle p r c | p == c = Just p
+                    | magV (p -.- c) < r = Just p
+                    | otherwise = Nothing
+
+--determines if a moving point intersects with a circle,
+--if so, returns a point on circle that intersects with the line passing
+--throught the circle : HOPEFULLY THE CORRECT OF THE TWO!
+
+collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
+collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad
+
+-- changes the point to a measure of the distance
+collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float
+collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1))
+                                    (collidePointCirc p1 p2 rad c)
+
+--returns both the point and the measure of the distance
+collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float)
+collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c
+                                     <*>  collidePointCirc' p1 p2 rad c
+                                     
+collidePointCircCorrect :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
+collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad
+
+
+-- finds the height of a triangle using herons formula
+-- the base is the line between the first two points
+heron :: Point2 -> Point2 -> Point2 -> Float
+heron x y z | x == y = 0
+            | otherwise = let a = magV $ x -.- y
+                              b = magV $ y -.- z
+                              c = magV $ z -.- x
+                              s = (a+b+c)/2
+                              area = sqrt(s*(s-a)*(s-b)*(s-c))
+                          in  2*area/a
+-- multiplies reflection in normal by factor
+reflectInParam :: Float -> Point2 -> Point2 -> Point2
+reflectInParam x line vec = let angle = 2 * angleBetween line vec
+                                rAng = rotateV angle vec
+                                p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng
+                            in  rAng -.- p
+
+
+reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
+reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
+
+isOnLine :: Point2 -> Point2 -> Point2 -> Bool
+isOnLine l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
+                    && errorClosestPointOnLineParam 11 l1 l2 p <= 1
+                    && errorClosestPointOnLineParam 12 l1 l2 p >= 0
+
+-- the take 5000 here is a hack, otherwise divideLine seems to sometimes
+-- generate an infinite list, and I don't know why
+divideLine :: Float -> Point2 -> Point2 -> [Point2]
+--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) 
+divideLine x a b = take 5000 $ map (\i -> a +.+ (i / (fromIntegral numPoints) *.* (b -.- a)) )
+                       $ map fromIntegral ns
+    where d = dist a b
+          numPoints = max 1 $ ceiling $ d / x
+          ns = [0 .. numPoints]
+
+
+-- pulled the following from the haskell wiki
+bresenham :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
+{-# INLINE bresenham #-}
+bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0)
+  where
+    steep = abs (yb - ya) > abs (xb - xa)
+    maySwitch = if steep then (\(x,y) -> (y,x)) else id
+    [(x1,y1),(x2,y2)] = sort [maySwitch pa, maySwitch pb]
+    deltax = x2 - x1
+    deltay = abs (y2 - y1)
+    ystep = if y1 < y2 then 1 else -1
+    go (xTemp, yTemp, error)
+        | xTemp > x2 = Nothing
+        | otherwise  = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
+        where
+          tempError = error + deltay
+          (newY, newError) = if (2*tempError) >= deltax
+                            then (yTemp+ystep,tempError-deltax)
+                            else (yTemp,tempError)
+
+
+divideCircle :: Float -> Point2 -> Float -> [Point2]
+divideCircle x cen rad = map (cen +.+) $ nPointsOnCirc n rad
+    where n = ceiling $ rad * 2 * pi / x
+
+nPointsOnCirc :: Int -> Float -> [Point2]
+nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (rad,0)
+
+lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
+lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps 
+                        || any (isJust . uncurry (intersectSegSeg' a b)) pss
+ where pss = zip ps (tail ps ++ [head ps])
+
+--intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+--intersectSegLineFrom a b c d 
+--    = case intersectSegLine a b c d of
+--                Just p | closestPointOnLineParam c d p >= 0 -> Just p
+--                       | otherwise                          -> Nothing
+--                Nothing                                     -> Nothing
+
+intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegSeg' #-}
+intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+--    | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
+--        = Nothing
+    | den == 0 = Nothing
+    | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den)
+        = Nothing
+    | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den)
+        = Nothing
+--    | den > 0 && (t' < 0 || t' > den)
+--        = Nothing
+--    | den < 0 && (t' > 0 || t' < 0-den)
+--        = Nothing
+    | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
+    where 
+        den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
+        t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
+        u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
+
+intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegLineFrom' #-}
+intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+--    | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
+--        = Nothing
+    | den == 0 = Nothing
+    | den > 0 && ( t' < 0 || u' < 0 || t' > den )
+        = Nothing
+    | den < 0 && ( t' > 0 || u' > 0 || t' < den )
+        = Nothing
+--    | den > 0 && (t' < 0 || t' > den)
+--        = Nothing
+--    | den < 0 && (t' > 0 || t' < 0-den)
+--        = Nothing
+    | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
+    where 
+        den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
+        t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
+        u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
+
+intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegLine' #-}
+intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+--    | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
+--        = Nothing
+    | den == 0 = Nothing
+    | den > 0 && (t' < 0 || t' > den)
+        = Nothing
+    | den < 0 && (t' > 0 || t' < den)
+        = Nothing
+--    | den > 0 && (t' < 0 || t' > den)
+--        = Nothing
+--    | den < 0 && (t' > 0 || t' < 0-den)
+--        = Nothing
+    | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
+    where 
+        den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
+        t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
+        u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
+
+intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectLineLine' #-}
+intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+    | den == 0 = Nothing
+    | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
+    where 
+        den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
+        t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)

src/Geometry/Data.hs

@@ -0,0 +1,8 @@
+module Geometry.Data
+    ( Point2 (..)
+    , Point3 (..)
+    )
+    where
+
+type Point2 = (Float,Float)
+type Point3 = (Float,Float,Float)

src/Loop.hs

@@ -0,0 +1,120 @@
+module Loop
+    ( setupLoop
+--    , withExits
+    ) where
+import SDL
+import qualified Data.Text as T
+import Control.Concurrent
+import Control.Exception
+import qualified Graphics.Rendering.OpenGL as GL
+import Control.Monad
+import System.Mem
+import Foreign.C
+import Geometry
+
+winConfig x y = defaultWindow 
+    { windowGraphicsContext
+        = OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
+                                       , glColorPrecision = V4 8 8 8 8
+                                       } 
+                        )
+    , windowInitialSize = V2 x y
+    , windowResizable =True
+    }
+
+setupLoop :: String
+        -> CInt
+        -> CInt
+        -> IO setupParams
+        -> (setupParams -> IO ())
+        -> world
+        -> (setupParams -> world -> IO ())
+        -> (world -> Event -> Maybe world)
+        -> (world -> Maybe world)
+        -> IO ()
+setupLoop wName xSize ySize 
+            customInit initCleanup startWorld sideEffects eventFn worldFn = do 
+    initializeAll
+    bracket (createWindow (T.pack wName) (winConfig xSize ySize)) destroyWindow
+        (\window -> 
+            do bracket (glCreateContext window) (\con -> GL.finish >> glDeleteContext con)
+                 (\_ -> bracket customInit initCleanup $ \setup -> do --  setup <- customInit
+--                            swapInterval $= ImmediateUpdates
+                            GL.blend $= GL.Enabled
+                            GL.blendEquation $= GL.FuncAdd
+                            GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha)
+                            GL.clearColor $= GL.Color4 0 0.5 0 0
+                            doLoop setup window startWorld
+                                   sideEffects eventFn worldFn
+                 )
+        )
+
+
+--doLoop :: setupParams -> Window -> WorldView world0
+--            -> (setupParams -> WorldView world0 -> IO ()) 
+--            -> (world0 -> Event -> Maybe world0) 
+--            -> (world0 -> Maybe world0) 
+--            -> IO ()
+doLoop setup window startWorld
+        worldSideEffects 
+        eventFn 
+        worldUpdate 
+  = do
+    startLoopTicks <- ticks
+    events <- pollEvents
+    --let-- maybeUpdatedWorld :: Maybe (WorldView world0)
+    --    maybeUpdatedWorld = applyEvents eventFn startWorld events worldUpdate
+    maybeUpdatedWorld <- applyEventsIO eventFn startWorld events
+    case maybeUpdatedWorld >>= worldUpdate of
+        Just updatedWorld -> do 
+            GL.clear [GL.ColorBuffer,GL.DepthBuffer]
+            worldSideEffects setup updatedWorld
+            glSwapWindow window
+            --GL.flush
+            performGC
+            endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic)
+            let delay = max 0 (10 + fromIntegral startLoopTicks - fromIntegral endLoopTicks)
+            threadDelay (delay * 1000)
+            doLoop setup window updatedWorld worldSideEffects eventFn worldUpdate
+        Nothing -> return ()
+
+applyEvents :: (world0 -> Event -> Maybe world0)
+                -> world0 
+                -> [Event]
+                -> (world0 -> Maybe world0)
+                -> Maybe world0
+applyEvents eventFn startWorld events worldUpdate = 
+    case foldM (applyH eventFn) startWorld events of
+        Just w -> fmap (\w' -> w') $ worldUpdate w
+        Nothing -> Nothing
+    where
+        applyH :: (world0 -> Event -> Maybe world0) -> world0 -> Event -> Maybe world0
+        applyH f w e 
+            = case eventPayload e of
+                QuitEvent -> Nothing
+                WindowClosedEvent _ -> Nothing
+                _ -> f w e
+
+-- applyResizeExits :: (world -> Event -> Maybe world) -> (world -> Event -> Maybe world)
+-- applyResizeExits f w e 
+--     = case eventPayload e of
+--         QuitEvent -> Nothing
+--         WindowClosedEvent _ -> Nothing
+--         WindowSizeChangedEvent
+--          (WindowSizeChangedEventData {windowSizeChangedEventWindow = V2 x y})
+--             -> GL.viewport
+--         _   -> f w e
+applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
+applyEventIO fn mw e = case eventPayload e of
+    QuitEvent -> return Nothing
+    WindowClosedEvent _ -> return Nothing
+    WindowSizeChangedEvent
+     (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
+        -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
+    _   -> return $ mw >>= flip fn e
+
+applyEventsIO :: (world0 -> Event -> Maybe world0)
+                -> world0 
+                -> [Event]
+                -> IO (Maybe world0)
+applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es

src/Picture.hs

@@ -0,0 +1,249 @@
+--{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Strict #-}
+module Picture
+    ( module Picture.Data
+    , polygon
+    , arc
+    , arcSolid
+    , thickArc
+    , thickCircle
+    , circleSolid
+    , circle
+    , line
+    , text
+    , pictures
+    , translate
+    , rotate
+    , rotateRad
+    , scale
+    , blank
+    , color
+    , withAlpha
+    , greyN
+    , red       
+    , green     
+    , blue      
+    , yellow    
+    , cyan      
+    , magenta   
+    , rose      
+    , violet    
+    , azure     
+    , aquamarine
+    , chartreuse
+    , orange    
+    , white     
+    , black
+    , dim
+    , light
+    , dark
+    , bright
+    , mixColors
+    , zeroZ
+    , setDepth
+    )
+    where
+import Geometry
+import Geometry.Data
+
+import Picture.Data
+
+import Data.Bifunctor
+import qualified Data.DList as DL
+
+import Graphics.Rendering.OpenGL (lineWidth, ($=),PrimitiveMode (..))
+
+import Control.Lens
+
+black :: RGBA
+black = (0,0,0,1)
+
+polygonD :: Float -> [Point2] -> Picture
+{-# INLINE polygonD #-}
+polygonD d (a:b:c:ps) = blank
+    { _scPosTri = DL.fromList $ map (\(x,y) -> (x,y,d)) tris
+    , _scColTri = DL.fromList $ map (const black) tris
+    }
+    where twoPs = zip (b:c:ps) (c:ps)
+          tris = concatMap (\(x,y)-> [a,x,y]) twoPs
+polygonD _ _ = blank
+
+polygon :: [Point2] -> Picture
+{-# INLINE polygon #-}
+polygon (a:b:c:ps) = blank
+    { _scPosTri = DL.fromList $ map zeroZ tris
+    , _scColTri = DL.fromList $ map (const black) tris
+    }
+    where twoPs = zip (b:c:ps) (c:ps)
+          tris = concatMap (\(x,y)-> [a,x,y]) twoPs
+polygon _ = blank
+
+color :: RGBA -> Picture -> Picture
+{-# INLINE color #-}
+color c = over scColTri (DL.map $ const c) . over scColChar (DL.map $ const c)
+
+translate3 :: Float -> Float -> Point3 -> Point3
+{-# INLINE translate3 #-}
+translate3 a b (x,y,z) = (x+a,y+b,z)
+
+translate :: Float -> Float -> Picture -> Picture
+{-# INLINE translate #-}
+translate x y = over scPosTri (DL.map $ translate3 x y) . over scPosChar (DL.map $ translate3 x y)
+
+setDepth :: Float -> Picture -> Picture
+setDepth d = over scPosTri (DL.map $ (\(x,y,z)->(x,y,d)))
+             . over scPosChar (DL.map $ (\(x,y,z)->(x,y,d)))
+
+--overVs' :: (CPoint2 -> CPoint) -> Picture -> Picture
+----{-# INLINE overVs' #-}
+--overVs' f !(Scene a b) = let !a' = map f a
+--                             !b' = map g b
+--                         in  Scene a' b'
+--    where g !(x,y,z) = let !(x',y') = f (x,y)
+--                       in  (x',y',z)
+
+scale3 :: Float -> Float -> Point3 -> Point3
+{-# INLINE scale3 #-}
+scale3 a b (x,y,z) = (x*a,y*b,z)
+
+scale :: Float -> Float -> Picture -> Picture
+{-# INLINE scale #-}
+scale x y = over scPosTri (DL.map $ scale3 x y) . over scPosChar (DL.map $ scale3 x y)
+
+rotate3 :: Float -> Point3 -> Point3
+{-# INLINE rotate3 #-}
+rotate3 a (x,y,z) = (x',y',z)
+    where (x',y') = rotateV a (x,y)
+
+rotate :: Float -> Picture -> Picture
+{-# INLINE rotate #-}
+rotate a = over scPosTri (DL.map $ rotate3 (0 - degToRad a)) 
+            . over scPosChar (DL.map $ rotate3 (0 - degToRad a))
+
+--  -- this rotation uses radians, and is anticlockwise
+rotateRad :: Float -> Picture -> Picture
+{-# INLINE rotateRad #-}
+rotateRad a = over scPosTri (DL.map $ rotate3 a) 
+            . over scPosChar (DL.map $ rotate3 a)
+
+pictures :: [Picture] -> Picture
+{-# INLINE pictures #-}
+pictures = mconcat
+
+
+makeArc :: Float -> (Float,Float) -> [Point2]
+{-# INLINE makeArc #-}
+makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
+    where as = [a,a+step.. b]
+          step = pi * 0.1
+
+circleSolidD :: Float -> Float -> Picture
+circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
+
+circleSolid :: Float -> Picture
+{-# INLINE circleSolid #-}
+circleSolid rad = polygon $ makeArc rad (0,2*pi)
+
+circle :: Float -> Picture
+{-# INLINE circle #-}
+circle rad = line $ makeArc rad (0,2*pi)
+
+--text :: String -> Picture
+--text s = zipWith (\x -> overVs $ first $ translate3 x 0) 
+--                 [0,0.25..]
+--                 $ map charToShape s
+
+text :: String -> Picture
+{-# INLINE text #-}
+text s = mconcat $ zipWith (\x -> translate x (0-dimText)) 
+                           [0,0.9*dimText..] 
+                           (map charToScene s)
+
+charToScene :: Char -> Picture
+charToScene c = Scene
+    {_scPosTri = DL.empty
+    ,_scColTri = DL.empty
+    ,_scPosChar = DL.fromList [(0.0    ,0.0      ,0)        
+                  ,(dimText,0.0      ,0)    
+                  ,(dimText,dimText*2,0)
+                  ,(0.0    ,0.0      ,0)        
+                  ,(dimText,dimText*2,0)
+                  ,(0.0    ,dimText*2,0)    
+                  ]
+    ,_scColChar = DL.fromList $ take 6 $ repeat white
+    ,_scTexChar = DL.fromList $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
+    }
+    where x = 1/128
+          s = offset * x
+          e = s + x
+          offset = fromIntegral (fromEnum c) - 32
+    
+
+dimText = 100
+
+line :: [Point2] -> Picture
+{-# INLINE line #-}
+line ps = thickLine ps 1
+
+thickLine :: [Point2] -> Float -> Picture
+{-# INLINE thickLine #-}
+thickLine ps x = blank
+
+thickCircle :: Float -> Float -> Picture
+{-# INLINE thickCircle #-}
+thickCircle rad wdth = thickLine (makeArc rad (0,2*pi)) wdth
+
+arcSolid :: Float -> Float -> Float -> Picture
+{-# INLINE arcSolid #-}
+arcSolid startA endA rad
+    = polygon $ (0,0) : makeArc rad (startA,endA)
+
+arc startA endA rad = thickArc startA endA rad 1
+{-# INLINE arc #-}
+
+thickArc :: Float -> Float -> Float -> Float -> Picture
+{-# INLINE thickArc #-}
+thickArc startA endA rad wdth
+    = thickLine (makeArc rad (startA,endA)) wdth
+
+withAlpha :: Float -> RGBA -> RGBA
+{-# INLINE withAlpha #-}
+withAlpha a (x,y,z,a') = (x,y,z,a*a')
+
+red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color
+red       = (1,0,0,1) 
+green     = (0,1,0,1) 
+blue      = (0,0,1,1) 
+yellow    = (1,1,0,1)  
+cyan      = (0,1,1,1) 
+magenta   = (1,0,1,1)  
+rose      = (1,0,0.5,1) 
+violet    = (0.5,0,1,1)  
+azure     = (0,0.5,1,1) 
+aquamarine= (0,1,0.5,1) 
+chartreuse= (0.5,1,0,1)
+orange    = (1,0.5,0,1)  
+white     = (1,1,1,1) 
+
+mixColors :: Float -> Float -> Color -> Color -> Color
+mixColors rata ratb (r0,g0,b0,a0) (r2,g2,b2,a2) = 
+    let fullrat = rata + ratb
+        normrata = rata / fullrat
+        normratb = ratb / fullrat
+        f x y = sqrt $ normrata * x^2 + normratb * y^2
+    in  (f r0 r2 , f g0 g2 , f b0 b2 , normrata * a0 + normratb * a2)
+
+light :: Color -> Color
+light (r,g,b,a) = (r+0.2,g+0.2,b+0.2,a)
+
+dark :: Color -> Color
+dark (r,g,b,a) = (r-0.2,g-0.2,b-0.2,a)
+        
+dim :: Color -> Color
+dim (r,g,b,a) = (r/1.2,g/1.2,b/1.2,a)
+
+bright :: Color -> Color
+bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
+
+greyN :: Float -> Color
+greyN x = (x,x,x,1)

src/Picture/Data.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE Strict #-}
+module Picture.Data
+    where
+import Data.Monoid
+import qualified Data.DList as DL
+import Geometry.Data
+
+import Control.Lens
+
+type RGBA = (Float,Float,Float,Float)
+type Color = (Float,Float,Float,Float)
+
+data Picture = Scene
+    { _scPosTri  :: DL.DList Point3
+    , _scColTri  :: DL.DList RGBA
+    , _scPosChar :: DL.DList Point3
+    , _scColChar :: DL.DList RGBA
+    , _scTexChar :: DL.DList Point2
+    }
+
+blank :: Picture
+{-# INLINE blank #-}
+blank = Scene DL.empty DL.empty DL.empty DL.empty DL.empty 
+
+combineScenes :: Picture -> Picture -> Picture
+{-# SCC combineScenes #-}
+--{-# INLINE combineScenes #-}
+combineScenes sa sb = Scene
+    { _scPosTri  = _scPosTri  sa <> _scPosTri sb
+    , _scColTri  = _scColTri  sa <> _scColTri sb
+    , _scPosChar = _scPosChar sa <> _scPosChar sb
+    , _scColChar = _scColChar sa <> _scColChar sb
+    , _scTexChar = _scTexChar sa <> _scTexChar sb
+    }
+
+instance Semigroup Picture where
+    (<>) = combineScenes
+instance Monoid Picture where
+    mempty = blank
+    --mappend = combineScenes
+
+makeLenses ''Picture

src/Picture/Preload.hs

@@ -0,0 +1,156 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE Strict #-}
+module Picture.Preload
+    where
+
+import Codec.Picture
+import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
+import qualified Graphics.Rendering.OpenGL as GL
+
+import qualified Data.Vector.Storable as V
+
+import Control.Lens
+
+import Foreign
+
+import Shaders
+
+data PreloadData = PreloadData
+    { _charMap :: Image PixelRGBA8
+--    , _textures :: [Image PixelRGBA8]
+    , _basicShader :: Program
+    , _textShader :: Program
+    , _fadeCircleShader :: Program
+    , _basicVAO :: VertexArrayObject
+    , _textVAO  :: VertexArrayObject
+    , _posVBO :: BufferObject
+    , _colVBO :: BufferObject
+    , _texVBO :: BufferObject
+    , _ptrPosVBO :: Ptr Float
+    , _ptrColVBO :: Ptr Float
+    , _ptrTexVBO :: Ptr Float
+    }
+
+makeLenses ''PreloadData
+
+
+loadTextures :: IO [Image PixelRGBA8]
+loadTextures = do
+--    echarMap <- readImage "data/texture/smudgedDirt.png"
+    echarMap <- readImage "data/texture/charMap.png"
+    case echarMap of
+        Left err -> do 
+            putStrLn err
+            return []
+        Right charMap -> 
+            return [convertRGBA8 charMap]
+
+bufferOffset :: Integral a => a -> Ptr b
+bufferOffset = plusPtr nullPtr . fromIntegral
+
+doPreload' :: IO PreloadData
+doPreload' = do
+-- compile shader programs
+    bs <- makeBasicShader
+    ts <- makeTextureShader
+    fcs <- makeFadeShader
+
+--setup vbos
+--need to be bound before assigning the vertex attribute pointers
+    posVBO <- genObjectName
+    colVBO <- genObjectName
+    texVBO <- genObjectName
+
+-- load charmap as texture
+--    Right cmap <- readImage "data/texture/smudgedDirt.png"
+    Right cmap <- readImage "data/texture/charMap.png"
+    let tex = convertRGBA8 cmap
+    texo <- genObjectName
+    textureBinding Texture2D $= Just texo
+    let texData = V.toList $ imageData tex
+        wtex = fromIntegral $ imageWidth  tex
+        htex = fromIntegral $ imageHeight tex
+    withArray texData $ \ptr -> do
+        texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 
+                        (PixelData RGBA UnsignedByte ptr)
+    generateMipmap' Texture2D
+    textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
+
+    let vertexSize = sizeOf (0.5 :: GLfloat)
+        firstIndex = 0
+
+-- setup VAOs: basic vao
+    basicVAO <- genObjectName
+    bindVertexArrayObject $= Just basicVAO
+
+--    let posAttrib = AttribLocation 0
+--        colAttrib = AttribLocation 1
+    bindBuffer ArrayBuffer $= Just posVBO
+    vertexAttribPointer (AttribLocation 0) $=
+        ( ToFloat
+        , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3) 
+                                            (bufferOffset (firstIndex * vertexSize))
+        )
+    vertexAttribArray (AttribLocation 0) $= Enabled
+
+    bindBuffer ArrayBuffer $= Just colVBO
+    vertexAttribPointer (AttribLocation 1) $=
+        ( ToFloat
+        , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4) 
+                                            (bufferOffset (firstIndex * vertexSize) )
+        )
+    vertexAttribArray (AttribLocation 1) $= Enabled
+
+-- setup second vao
+    textVAO <- genObjectName
+    bindVertexArrayObject $= Just textVAO
+
+    bindBuffer ArrayBuffer $= Just posVBO
+    vertexAttribPointer (AttribLocation 0) $=
+        ( ToFloat
+        , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3) 
+                                            (bufferOffset (firstIndex * vertexSize))
+        )
+    vertexAttribArray (AttribLocation 0) $= Enabled
+
+    bindBuffer ArrayBuffer $= Just colVBO
+    vertexAttribPointer (AttribLocation 1) $=
+        ( ToFloat
+        , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4) 
+                                            (bufferOffset (firstIndex * vertexSize) )
+        )
+    vertexAttribArray (AttribLocation 1) $= Enabled
+
+    bindBuffer ArrayBuffer $= Just texVBO
+    vertexAttribPointer (AttribLocation 2) $=
+        ( ToFloat
+        , VertexArrayDescriptor 2 Float (fromIntegral $ vertexSize * 2) 
+                                            (bufferOffset (firstIndex * vertexSize) )
+        )
+    vertexAttribArray (AttribLocation 2) $= Enabled
+
+-- allocate memory for vertex attributes
+    ptrPosVBO <- mallocArray (3*3*5000)
+    ptrColVBO <- mallocArray (3*4*5000)
+    ptrTexVBO <- mallocArray (3*2*5000)
+
+    return $ PreloadData
+        { _charMap      = convertRGBA8 cmap
+        , _basicShader  = bs
+        , _textShader   = ts
+        , _fadeCircleShader = fcs
+        , _basicVAO = basicVAO
+        , _textVAO  = textVAO
+        , _posVBO = posVBO
+        , _colVBO = colVBO
+        , _texVBO = texVBO
+        , _ptrPosVBO = ptrPosVBO
+        , _ptrColVBO = ptrColVBO
+        , _ptrTexVBO = ptrTexVBO
+        }
+
+cleanUpPreload :: PreloadData -> IO ()
+cleanUpPreload pd = do
+    free (_ptrPosVBO pd)
+    free (_ptrColVBO pd)
+    free (_ptrTexVBO pd)

src/Picture/Render.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE Strict #-}
+module Picture.Render
+    where
+import Control.Lens
+import Picture
+import Geometry
+
+import Picture.Preload
+--import Control.Lens
+
+import Foreign
+
+import Codec.Picture
+
+import Graphics.Rendering.OpenGL hiding (translate,scale,imageHeight,imageWidth)
+import qualified Graphics.Rendering.OpenGL as GL
+
+import Data.Foldable
+import qualified Data.Vector.Storable as V
+import qualified Data.DList as DL
+
+import Control.DeepSeq
+
+concat34 :: (Point3,RGBA) -> [Float]
+concat34 ((x,y,z),(r,g,b,a)) = [x,y,z,r,g,b,a]
+
+
+toVec2 (x,y) = Vector2 x y
+toVec3 (x,y,z) = Vector3 x y z
+toVec4 (x,y,z,w) = Vector4 x y z w
+
+flat2 (x,y)     = DL.fromList [x,y]
+flat3 (x,y,z)   = DL.fromList [x,y,z]
+flat4 (x,y,z,w) = DL.fromList [x,y,z,w]
+
+mapFlat :: (NFData b) => (a -> DL.DList b) -> DL.DList a -> [b]
+mapFlat f = force . DL.toList . foldMap f
+
+--marshallVs = V.unsafeWith . V.fromList
+--marshallVs = withArray
+
+renderPicture' :: PreloadData -> Picture -> IO ()
+renderPicture' pdata (Scene posTri' colTri' posChar' colChar' texChar') = do
+    let posTri = DL.toList posTri'
+        colTri = DL.toList colTri'
+        posChar = DL.toList posChar'
+        colChar = DL.toList colChar'
+        texChar = DL.toList texChar'
+    currentProgram $= Just (_basicShader pdata)
+    bindVertexArrayObject $= Just (_basicVAO pdata)
+    bindBuffer ArrayBuffer $= Just (_posVBO pdata)
+    let firstIndex = 0
+    let vertices :: [Float]
+        vertices = mapFlat flat3 posTri'
+        numVertices = length vertices
+        vertexSize = sizeOf (head vertices)
+    pokeArray (_ptrPosVBO pdata) vertices
+    bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
+--    marshallVs vertices $ \ptr -> do
+--        bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
+    bindBuffer ArrayBuffer $= Just (_colVBO pdata)
+    let colVs = mapFlat flat4 colTri'
+        colVsize = sizeOf $ head colVs
+    pokeArray (_ptrColVBO pdata) colVs
+    bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), _ptrColVBO pdata, StreamDraw)
+--    marshallVs colVs $ \ptr -> do
+--        bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
+    drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
+
+--    currentProgram $= Just (_textShader pdata)
+--    bindVertexArrayObject $= Just (_textVAO pdata)
+--    bindBuffer ArrayBuffer $= Just (_posVBO pdata)
+--    let vertices' = mapFlat flat3 posChar'
+--        numVertices' = length vertices'
+--        vertexSize'  = sizeOf $ head vertices'
+--    withArray vertices' $ \ptr -> do
+--        bufferData ArrayBuffer $= (fromIntegral (numVertices' * vertexSize'), ptr, StreamDraw)
+--    bindBuffer ArrayBuffer $= Just (_colVBO pdata)
+--    let colVsT = mapFlat flat4 colChar'
+--        colVsTsize  = sizeOf $ head colVsT
+--    withArrayLen colVsT $ \numV' ptr -> do
+--        bufferData ArrayBuffer $= (fromIntegral (numVertices' * colVsTsize), ptr, StreamDraw)
+--    bindBuffer ArrayBuffer $= Just (_texVBO pdata)
+--    let texVsT = mapFlat flat2 texChar'
+--        texVsTsize  = sizeOf $ head texVsT
+--    withArrayLen texVsT $ \numV' ptr -> do
+--        bufferData ArrayBuffer $= (fromIntegral (numVertices' * texVsTsize), ptr, StreamDraw)
+--    drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices')
+
+
+
+bufferOffset :: Integral a => a -> Ptr b
+bufferOffset = plusPtr nullPtr . fromIntegral
+
+zeroZ :: Point2 -> Point3
+zeroZ (x,y) = (x,y,0)

src/Render.hs

@@ -0,0 +1,108 @@
+module Render where
+import Shapes
+import Graphics.Rendering.OpenGL hiding (imageHeight,imageWidth)
+import Foreign
+import Loop
+import Codec.Picture
+import qualified Data.Vector.Storable as V
+
+
+render :: [Program] -> b -> Shape -> IO ()
+render progs _ (Shape primitiveMode vs) = do 
+    currentProgram $= Just (progs !! 0)
+    let vertices = flattenVertices vs
+        numVertices = length vertices
+        vertexSize = sizeOf (head vertices)
+
+    -- setup VBO
+    shape <- genObjectName
+    bindVertexArrayObject $= Just shape
+
+    -- setup VBA
+    arrayBuffer <- genObjectName
+    bindBuffer ArrayBuffer  $= Just arrayBuffer
+    withArray vertices $ \ptr -> do
+        bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StaticDraw)
+
+    let firstIndex = 0
+        vPosition = AttribLocation 0
+        vColor    = AttribLocation 1
+    vertexAttribPointer vPosition $=
+        ( ToFloat
+        , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 7) 
+                                            (bufferOffset (firstIndex * vertexSize))
+        )
+    vertexAttribArray vPosition $= Enabled
+
+    vertexAttribPointer vColor $=
+        ( ToFloat
+        , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 7) 
+                                            (bufferOffset ((firstIndex + 3) * vertexSize) )
+        )
+    vertexAttribArray vColor $= Enabled
+    
+--    clear [ColorBuffer,DepthBuffer]
+
+    bindVertexArrayObject $= Just shape
+    drawArrays primitiveMode (fromIntegral firstIndex) (fromIntegral $ div numVertices 2)
+    
+
+render (_:prog:_) _ (Fade ps) = do 
+    currentProgram $= Just prog
+    let vertices = flatten2 ps
+        numVertices = length vertices
+        vertexSize = sizeOf (head vertices)
+
+--    -- setup uniform
+--    location <- get $ uniformLocation prog "winSize"
+--    uniform location $= winSizeVec
+
+    -- setup VBO
+    arrayBuffer <- genObjectName
+    bindBuffer ArrayBuffer  $= Just arrayBuffer
+    withArray vertices $ \ptr -> do
+        bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
+
+    -- setup VAO
+    shape <- genObjectName
+    bindVertexArrayObject $= Just shape
+
+    let firstIndex = 0
+        inPosition = AttribLocation 0
+        inColor    = AttribLocation 1
+        inRad    = AttribLocation 2
+    vertexAttribPointer inPosition $=
+        ( ToFloat
+        , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 8) 
+                                            (bufferOffset (firstIndex * vertexSize))
+        )
+    vertexAttribArray inPosition $= Enabled
+
+    vertexAttribPointer inColor $=
+        ( ToFloat
+        , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 8) 
+                                            (bufferOffset ((firstIndex + 3) * vertexSize) )
+        )
+    vertexAttribArray inColor $= Enabled
+
+    vertexAttribPointer inRad $=
+        ( ToFloat
+        , VertexArrayDescriptor 1 Float (fromIntegral $ vertexSize * 8) 
+                                            (bufferOffset ((firstIndex + 7) * vertexSize) )
+        )
+    vertexAttribArray inRad $= Enabled
+    
+--    bindVertexArrayObject $= Just shape
+    drawArrays Points (fromIntegral firstIndex) (2)
+    
+
+flattenVertices :: [CPoint] -> [GLfloat]
+flattenVertices = map realToFrac . concatMap (\(CPoint (x,y,z) (r,b,g,a)) -> [x,y,z,r,b,g,a])
+
+flatten2 :: [((Float,Float,Float),(Float,Float,Float,Float),Float)] -> [GLfloat]
+flatten2 = map realToFrac . concatMap f 
+    where f ((x,y,z),(r,g,b,a),rad) = [x,y,z,r,g,b,a,rad]
+
+bufferOffset :: Integral a => a -> Ptr b
+bufferOffset = plusPtr nullPtr . fromIntegral
+

src/Rendering/Picture/Color.hs

@@ -0,0 +1,21 @@
+module Rendering.Picture.Color
+    where
+import Geometry.Data
+
+type RGBA = (Float,Float,Float,Float)
+
+black,red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::RGBA
+black     = (0,0,0,1)
+red       = (1,0,0,1) 
+green     = (0,1,0,1) 
+blue      = (0,0,1,1) 
+yellow    = (1,1,0,1)  
+cyan      = (0,1,1,1) 
+magenta   = (1,0,1,1)  
+rose      = (1,0,0.5,1) 
+violet    = (0.5,0,1,1)  
+azure     = (0,0.5,1,1) 
+aquamarine= (0,1,0.5,1) 
+chartreuse= (0.5,1,0,1)
+orange    = (1,0.5,0,1)  
+white     = (1,1,1,1) 

src/Shaders.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Shaders 
+    (setupBasicShader
+    ,setupFadeShader
+    ,setupShaders
+    ,makeTextureShader
+    ,makeBasicShader
+    ,makeFadeShader
+    )
+    where
+import Graphics.Rendering.OpenGL
+import Control.Monad (when)
+import Text.RawString.QQ
+import qualified Data.ByteString as BS
+
+setupShaders :: IO [Program]
+setupShaders = do
+    basicShader <- makeBasicShader
+    fadeShader <- makeFadeShader
+    textureShader <- makeTextureShader
+    return [basicShader,fadeShader,textureShader]
+
+makeBasicShader :: IO Program
+makeBasicShader = do
+    vsSource <- BS.readFile "shader/basic.vert"
+    fsSource <- BS.readFile "shader/basic.frag"
+
+    makeShaderProgram [(VertexShader, vsSource)
+                      ,(FragmentShader, fsSource)
+                      ]
+
+setupBasicShader :: IO ()
+setupBasicShader = do
+    shaderProgram <- makeBasicShader
+    currentProgram $= (Just shaderProgram)
+
+makeFadeShader :: IO Program
+makeFadeShader = do
+    vsSource <- BS.readFile "shader/fadeCircle.vert"
+    gsSource <- BS.readFile "shader/fadeCircle.geom"
+    fsSource <- BS.readFile "shader/fadeCircle.frag"
+
+    makeShaderProgram [(VertexShader,   vsSource )
+                      ,(GeometryShader, gsSource )
+                      ,(FragmentShader, fsSource )
+                      ]
+
+setupFadeShader :: IO Program
+setupFadeShader = do
+    shaderProgram <- makeFadeShader
+    currentProgram $= (Just shaderProgram)
+    return shaderProgram
+
+makeTextureShader :: IO Program
+makeTextureShader = do
+    vsSource <- BS.readFile "shader/basicTexture.vert"
+    fsSource <- BS.readFile "shader/basicTexture.frag"
+
+    makeShaderProgram [(VertexShader,   vsSource )
+                      ,(FragmentShader, fsSource )
+                      ]
+
+makeShaderProgram :: [(ShaderType,BS.ByteString)] -> IO Program
+makeShaderProgram sources = do
+    shaderProgram <- createProgram
+    shaders <- mapM compileAndCheckShader sources
+    mapM_ (attachShader shaderProgram) shaders
+
+    linkProgram shaderProgram
+    linkingSuccess <- linkStatus shaderProgram
+    when (not linkingSuccess) $ do
+        infoLog <- get (programInfoLog shaderProgram)
+        putStrLn $ "Program Linking" ++ infoLog
+
+    return shaderProgram
+
+compileAndCheckShader :: (ShaderType,BS.ByteString) -> IO Shader
+compileAndCheckShader (shaderType,sourceCode) = do
+    theShader <- createShader shaderType
+    shaderSourceBS theShader $= sourceCode
+    compileShader theShader
+    success <- compileStatus theShader
+    when (not success) $ do
+        infoLog <- get (shaderInfoLog theShader)
+        putStrLn $ "Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
+    return theShader

src/Shapes.hs

@@ -0,0 +1,28 @@
+module Shapes where
+import Geometry
+import Graphics.Rendering.OpenGL
+
+type RGBA = (Float,Float,Float,Float)
+
+data CPoint = CPoint 
+    {cpPoint :: Point3
+    ,cpColor :: RGBA
+    }
+
+data Shape = Shape PrimitiveMode [CPoint]
+            | Fade [(Point3,RGBA,Float)]
+            | Shape' PrimitiveMode [GLfloat]
+
+egTri = Shape TriangleStrip [CPoint (-1,0,0) (1,1,1,1)
+                            ,CPoint (0,1,0) (1,1,0,1)
+                            ,CPoint (1,0,0) (1,0,1,0)
+                            ,CPoint (0.5,-0.5,0) (1,0,1,0)
+                            ,CPoint (0.5,-0.5,0) (1,0,1,0)
+                            ,CPoint (0.5,-0.5,0) (1,0,1,0)
+                            ]
+
+egFade = Fade [((-0.2,-0.2,0),(1,1,1,1),500)
+              ,((0.2,0.2,0),(1,1,1,1),500)
+--              ,((0.5,0.5,0),(1,1,1,1),0.5)
+--              ,((0.5,0.5,0),(1,1,1,1),0.5)
+              ]