Cleanup

data/dodge.config.json

@@ -14,7 +14,7 @@
   "_graphics_num_shadow_casters": "NumShadowCasters20",
   "_graphics_shadow_rendering": "GeoObjShads",
   "_graphics_shadow_size": "Typical",
-  "_graphics_world_resolution": "QuarterRes",
+  "_graphics_world_resolution": "HalfRes",
   "_volume_master": 1,
   "_volume_music": 0,
   "_volume_sound": 1,

ghcidOutput

@@ -1 +1 @@
-All good (596 modules, at 10:48:32)
+All good (596 modules, at 11:08:10)

src/Dodge/Block.hs

@@ -1,15 +1,19 @@
-module Dodge.Block where
+module Dodge.Block (
+    splinterBlock,
+    destroyBlock,
+    destroyDoor,
+) where
 
-import Control.Monad
-import Data.Set (Set)
-import Dodge.Data.MountedObject
 import Control.Lens
+import Control.Monad
 import Data.Foldable
 import qualified Data.Graph.Inductive as FGL
 import qualified Data.IntSet as IS
 import Data.Maybe
+import Data.Set (Set)
 import Dodge.Base.Collide
 import Dodge.Block.Debris
+import Dodge.Data.MountedObject
 import Dodge.Data.World
 import Dodge.DrWdWd
 import Dodge.LightSource
@@ -44,10 +48,10 @@ unshadowBlock w wlid = case w ^? cWorld . lWorld . walls . ix wlid of
             & insertWallInZones (wl & wlUnshadowed .~ True)
     Nothing -> w
 
-checkBlockHP :: Block -> World -> World
+--checkBlockHP :: Block -> World -> World
-checkBlockHP bl
+--checkBlockHP bl
-    | _blHP bl < 1 = destroyBlock bl
+--    | _blHP bl < 1 = destroyBlock bl
-    | otherwise = id
+--    | otherwise = id
 
 destroyBlock :: Block -> World -> World
 destroyBlock bl w =
@@ -74,8 +78,9 @@ maybeClearPath :: World -> PathEdgeNodes -> World
 maybeClearPath w (PathEdgeNodes x y pe)
     | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
         w
-    | otherwise = w 
+    | otherwise =
-        & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
+        w
+            & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
 
 destroyDoor :: Door -> World -> World
 destroyDoor dr w =

src/Dodge/Prop/Gib.hs

@@ -1,7 +1,9 @@
-module Dodge.Prop.Gib where
+module Dodge.Prop.Gib (
+    addCrGibs,
+) where
 
-import Control.Monad
 import Color
+import Control.Monad
 import Data.Foldable
 import Data.List (zip4)
 import Dodge.Base
@@ -30,17 +32,15 @@ aGib =
         }
 
 addCrGibs :: Creature -> World -> World
-addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of
+addCrGibs cr = case damageDirection $ _csDamage $ _crState cr of
     Nothing ->
-        w
+            addGibAt 25 (_skinHead skin) cpos
-            & addGibAt 25 (_skinHead skin) cpos
+            . addGibsAt 3 7 (_skinLower skin) cpos
-            & addGibsAt 3 7 (_skinLower skin) cpos
+            . addGibsAt 13 20 (_skinUpper skin) cpos
-            & addGibsAt 13 20 (_skinUpper skin) cpos
     Just d ->
-        w
+            addGibsAtDir d 3 7 (_skinLower skin) cpos
-            & addGibsAtDir d 3 7 (_skinLower skin) cpos
+            . addGibsAtDir d 13 20 (_skinUpper skin) cpos
-            & addGibsAtDir d 13 20 (_skinUpper skin) cpos
+            . addGibAtDir d 25 (_skinHead skin) cpos
-            & addGibAtDir d 25 (_skinHead skin) cpos
   where
     skin = _crType cr -- this should be cleaned up
     cpos = _crPos cr

src/Dodge/Tree/GenerateStructure.hs

@@ -3,43 +3,47 @@ Procedural generation of tree structures.
 
 A /trunk/ refers to the successive first nodes in lists of children.
 -}
-module Dodge.Tree.GenerateStructure
+module Dodge.Tree.GenerateStructure where
-    where
-import RandomHelp
-import Control.Monad
 
+import Control.Monad
 import Data.Tree
+import RandomHelp
+
 {- Single branched tree (a trunk).  -}
 treePath :: Int -> Tree ()
 treePath 0 = Node () []
-treePath x = Node () [treePath (x-1)]
+treePath x = Node () [treePath (x -1)]
 
 {- Adds a branch at a certain point down a trunk.  -}
-addBranchAt 
+addBranchAt ::
-    :: Int      -- ^ Depth to add branch at
+    -- | Depth to add branch at
-    -> Tree ()  -- ^ Branch to add
+    Int ->
-    -> Tree ()  -- ^ Starting tree
+    -- | Branch to add
-    -> Tree ()
+    Tree () ->
+    -- | Starting tree
+    Tree () ->
+    Tree ()
 addBranchAt 0 b (Node () xs) = Node () (xs ++ [b])
-addBranchAt i b (Node () (x:xs))
+addBranchAt i b (Node () (x : xs)) =
-    = Node () (addBranchAt (i-1) b x : xs)
+    Node () (addBranchAt (i -1) b x : xs)
 addBranchAt _ _ _ = error "Trying to add a branch too far along a tree"
 
 {- Randomly generate a tree containing a maximum of three nodes.  -}
 smallBranch :: RandomGen g => State g (Tree ())
-smallBranch = takeOne
+smallBranch =
-    [ treePath 0
+    takeOne
-    , treePath 1
+        [ treePath 0
-    , treePath 2
+        , treePath 1
-    , addBranchAt 0 (treePath 0) (treePath 1)
+        , treePath 2
-    ]
+        , addBranchAt 0 (treePath 0) (treePath 1)
+        ]
 
 {- Randomly generate a small tree.  -}
 aTreeStrut :: RandomGen g => State g (Tree ())
 aTreeStrut = do
-    d <- state $ randomR (9,11:: Int)
+    d <- state $ randomR (9, 11 :: Int)
-    nbs <- state $ randomR (2,4)
+    nbs <- state $ randomR (2, 4)
     bds <- takeN nbs [1 .. d - 1]
-    bs  <- replicateM nbs smallBranch
+    bs <- replicateM nbs smallBranch
     let trunk = treePath d
     return $ foldr (uncurry addBranchAt) trunk $ zip bds bs

src/Dodge/Update.hs

@@ -6,41 +6,32 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where
 
-import Dodge.Inventory
-import Dodge.ListDisplayParams
-import Dodge.SelectionSections
-import Data.Monoid
-import NewInt
-import Control.Monad
-import Dodge.Update.Input.InGame
-import Dodge.Update.Input.ScreenLayer
-import Dodge.Debug
-import Dodge.SmoothScroll
 import Color
---import Control.Applicative
+import Control.Monad
 import Data.List
 import qualified Data.Map.Strict as M
 import Data.Maybe
+import Data.Monoid
 import Dodge.Base
---import Dodge.Beam
 import Dodge.Bullet
 import Dodge.CrGroupUpdate
 import Dodge.Creature.Update
---import Dodge.Data.SelectionList
 import Dodge.Data.Universe
+import Dodge.Debug
 import Dodge.DisplayInventory
 import Dodge.Distortion
 import Dodge.DrWdWd
 import Dodge.EnergyBall
 import Dodge.Flame
+import Dodge.Inventory
 import Dodge.Item.Location
 import Dodge.Laser.Update
 import Dodge.LightSource.Update
 import Dodge.LinearShockwave.Update
+import Dodge.ListDisplayParams
 import Dodge.Machine.Update
 import Dodge.Magnet.Update
 import Dodge.Menu
---import Dodge.Menu.Option
 import Dodge.ModificationEffect
 import Dodge.PosEvent
 import Dodge.PressPlate
@@ -49,7 +40,9 @@ import Dodge.Prop.Update
 import Dodge.RadarBlip
 import Dodge.RadarSweep
 import Dodge.ScrollValue
+import Dodge.SelectionSections
 import Dodge.Shockwave.Update
+import Dodge.SmoothScroll
 import Dodge.SoundLogic
 import Dodge.Spark
 import Dodge.Tesla.Arc
@@ -57,6 +50,8 @@ import Dodge.TmTm
 import Dodge.TractorBeam.Update
 import Dodge.Update.Camera
 import Dodge.Update.Cloud
+import Dodge.Update.Input.InGame
+import Dodge.Update.Input.ScreenLayer
 import Dodge.Update.Scroll
 import Dodge.Update.WallDamage
 import Dodge.WallCreatureCollisions
@@ -66,6 +61,7 @@ import Dodge.Zoning.Creature
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
+import NewInt
 import SDL
 import Sound.Data
 import StrictHelp
@@ -92,22 +88,23 @@ updateUniverseFirst u =
 
 updateDebugMessageOffset :: Universe -> Universe
 updateDebugMessageOffset u
-    | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys)
+    | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
-        = u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
+        u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
     | otherwise = u
 
 setClickWorldPos :: Universe -> M.Map MouseButton Point2
-setClickWorldPos u = fmap 
+setClickWorldPos u =
-    (const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
+    fmap
-    (M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)
+        (const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
+        (M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)
 
 updateWorldEventFlags :: Universe -> Universe
 updateWorldEventFlags u =
     (uvWorld . worldEventFlags .~ mempty)
-    -- for now update inventory positioning every tick
+        -- for now update inventory positioning every tick
-    . updateInventoryPositioning
+        . updateInventoryPositioning
-    -- the question is how often to update the close objects section, and if
+        -- the question is how often to update the close objects section, and if
-    -- this can be done independently of the other sections
+        -- this can be done independently of the other sections
         $ foldr updateWorldEventFlag u (u ^. uvWorld . worldEventFlags)
 
 updateWorldEventFlag :: WorldEventFlag -> Universe -> Universe
@@ -136,8 +133,10 @@ updateUniverseLast u =
         & uvWorld . input . pressedKeys . each %~ f
         & uvWorld . input . mouseMoving .~ False
         & uvWorld . input . mouseButtons . each +~ 1
-        & uvWorld . input . heldPos %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
+        & uvWorld . input . heldPos
-        & uvWorld . input . heldWorldPos %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
+            %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
+        & uvWorld . input . heldWorldPos
+            %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
   where
     mp = u ^. uvWorld . input . mousePos
     mwp = screenToWorldPos (u ^. uvWorld . wCam) mp
@@ -166,9 +165,9 @@ timeFlowUpdate u = case u ^. uvWorld . timeFlow of
     NormalTimeFlow -> functionalUpdate u
     ItemScrollTimeFlow smoothing _ _ _ -> over uvWorld (doItemTimeScroll smoothing) u
     CameraScrollTimeFlow smoothing _ _
-        | SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) 
+        | SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) ->
-            -> over uvWorld (doTimeScroll smoothing) u
+            over uvWorld (doTimeScroll smoothing) u
-    CameraScrollTimeFlow {} -> u
+    CameraScrollTimeFlow{} -> u
     RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
     RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
     DeathTime{} -> u
@@ -214,8 +213,9 @@ scrollTimeBack w = case w ^? pastWorlds . _head of
     mupdateitem x = fromMaybe id $ do
         i <- w ^? timeFlow . scrollItemID . unNInt
         let pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse
-        return $ (pointituse . leftConsumption . wpCharge .~ (x -1))
+        return $
-                    . ( pointituse . leftHammer .~ HammerDown)
+            (pointituse . leftConsumption . wpCharge .~ (x -1))
+                . (pointituse . leftHammer .~ HammerDown)
 
 scrollTimeForward :: World -> World
 scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
@@ -254,7 +254,7 @@ functionalUpdate u =
         . over uvWorld updateEnergyBalls
         . over uvWorld updateBullets
         . over uvWorld updateRadarBlips
---        . over uvWorld updateBeams
+        --        . over uvWorld updateBeams
         . over uvWorld updateLasers
         . over uvWorld updateTeslaArcs
         . over uvWorld updateTractorBeams
@@ -278,7 +278,7 @@ functionalUpdate u =
         . over uvWorld updateRBList
         . over uvWorld updateCloseObjects
         . over uvWorld updateWheelEvents
-        . over uvWorld (updateMouseInventorySelection  (u ^. uvConfig))
+        . over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
         . over uvWorld (updateMouseOverInventory (u ^. uvConfig))
         . over uvWorld zoneClouds
         . over uvWorld zoneCreatures
@@ -308,26 +308,34 @@ updateMouseInventorySelection' sss cfig w
             return $ w & hud . hudElement . subInventory . nsSelected .~ MouseInvSelect ysel Nothing
         Just p -> w & hud . hudElement . subInventory . nsSelected %~ startdrag p
     | leftclickheld = case w ^? hud . hudElement . subInventory . nsSelected of
-        Just MouseInvSelect{} -> w 
+        Just MouseInvSelect{} ->
-            & hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
+            w
+                & hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
         Just (MouseInvChosen ssel esel)
-            | maybe False (<ssel) $ inverseSelBoundaryUp cfig ldp sss mpos -> w
+            | maybe False (< ssel) $ inverseSelBoundaryUp cfig ldp sss mpos ->
-                & shiftInvItemsUp ssel esel (inverseSelBoundaryUp cfig ldp sss mpos)
+                w
+                    & shiftInvItemsUp ssel esel (inverseSelBoundaryUp cfig ldp sss mpos)
         Just (MouseInvChosen ssel esel)
-            | maybe False (>esel) $ inverseSelBoundaryDown cfig ldp sss mpos -> w
+            | maybe False (> esel) $ inverseSelBoundaryDown cfig ldp sss mpos ->
-                & shiftInvItemsDown ssel esel (inverseSelBoundaryDown cfig ldp sss mpos)
+                w
+                    & shiftInvItemsDown ssel esel (inverseSelBoundaryDown cfig ldp sss mpos)
         Just (MouseInvChosen{}) -> w
-        _ -> w
+        _ ->
-            & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
+            w
+                & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
     | otherwise = case w ^? hud . hudElement . subInventory . nsSelected of
-        Just (MouseInvSelect ssel (Just esel)) -> w
+        Just (MouseInvSelect ssel (Just esel)) ->
-            & hud . hudElement . subInventory . nsSelected .~ MouseInvChosen (min ssel esel)
+            w
-                (max ssel esel)
+                & hud . hudElement . subInventory . nsSelected
-        Just (MouseInvSelect _ Nothing) -> w
+                    .~ MouseInvChosen
-            & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
+                        (min ssel esel)
+                        (max ssel esel)
+        Just (MouseInvSelect _ Nothing) ->
+            w
+                & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
         _ -> w
   where
-    startdrag p (MouseInvChosen s e) | s <= p && p <= e =  MouseInvChosen s e
+    startdrag p (MouseInvChosen s e) | s <= p && p <= e = MouseInvChosen s e
     startdrag p _ = MouseInvChosen p p
     leftclickstart = w ^? input . mouseButtons . ix ButtonLeft == Just 0 && nobuttonright
     leftclickheld = ButtonLeft `M.member` (w ^. input . mouseButtons) && nobuttonright
@@ -337,21 +345,23 @@ updateMouseInventorySelection' sss cfig w
     msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
     mysel = inverseSelSecYint (posSelSecYint cfig ldp (mpos ^. _y)) sss
 
-shiftInvItemsUp :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
+shiftInvItemsUp :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
-shiftInvItemsUp (_,i) (_,j) Just{} w = w
+shiftInvItemsUp (_, i) (_, j) Just{} w =
-    & flip (foldl' f) [i..j]
+    w
-    & hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
+        & flip (foldl' f) [i .. j]
-    & hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
+        & hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
+        & hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
   where
     f w' i' = swapInvItems g i' w'
     g i' m = fmap fst $ IM.cycleLT i' m
 shiftInvItemsUp _ _ Nothing w = w
 
-shiftInvItemsDown :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
+shiftInvItemsDown :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
-shiftInvItemsDown (_,i) (_,j) Just{} w = w
+shiftInvItemsDown (_, i) (_, j) Just{} w =
-    & flip (foldl' f) (reverse [i..j])
+    w
-    & hud . hudElement . subInventory . nsSelected . misChosenStart . _2 +~ 1
+        & flip (foldl' f) (reverse [i .. j])
-    & hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 +~ 1
+        & hud . hudElement . subInventory . nsSelected . misChosenStart . _2 +~ 1
+        & hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 +~ 1
   where
     f w' i' = swapInvItems g i' w'
     g i' m = fmap fst $ IM.cycleGT i' m
@@ -360,8 +370,9 @@ shiftInvItemsDown _ _ Nothing w = w
 updateMouseOverInventory :: Configuration -> World -> World
 updateMouseOverInventory cfig w = fromMaybe w $ do
     sss <- w ^? hud . hudElement . diSections
-    return $ w & hud . hudElement . subInventory . nsMouseOver .~
+    return $
-        inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
+        w & hud . hudElement . subInventory . nsMouseOver
+            .~ inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
   where
     ldp = invDisplayParams w
 
@@ -380,6 +391,7 @@ advanceScrollAmount u =
 
 updatePastWorlds :: World -> World
 updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
+
 --updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 600 . ((w ^. cWorld . lWorld) :))
 
 doWorldEvents :: World -> World
@@ -462,10 +474,12 @@ updateCreatureSoundPositions w =
 --updateIMr fim fup w = foldr (dbArg fup) w (fim w)
 updateIMl :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World
 updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w
+
 --updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
 
 updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
 updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w
+
 --updateIMl' fim fup w = foldl' (flip fup) w (fim w)
 
 updateCreatureGroups :: World -> World
@@ -638,10 +652,12 @@ ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ w
 
 updateSeenWalls :: World -> World
 updateSeenWalls w = alaf Endo foldMap (markWallSeen . _wlID . snd) (allVisibleWalls w) w
+
 --updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)
 
 markWallSeen :: Int -> World -> World
 markWallSeen i = cWorld . seenWalls . at i ?~ ()
+
 --markWallSeen :: World -> Int -> World
 --markWallSeen w i = w & cWorld . seenWalls . at i ?~ ()
 

src/Dodge/WorldEvent/Explosion.hs

@@ -8,10 +8,6 @@ module Dodge.WorldEvent.Explosion (
     makeTeslaExplosionAt,
 ) where
 
---import Dodge.WorldEvent.Flash
-
---import Geometry.Vector3D
-
 import Control.Monad
 import Data.List
 import Dodge.Base.Collide
@@ -27,8 +23,6 @@ import LensHelp
 import Picture
 import RandomHelp
 
---import Data.Maybe
-
 makePoisonExplosionAt ::
     -- | Position
     Point2 ->
@@ -97,7 +91,6 @@ makeExplosionAt p w =
     inversePushOut v = (15 - magV v) * 0.01 *.* v
     fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
     sizes = randomRs (2, 9) $ _randGen w
-    --times = randomRs (20,25) $ _randGen w
     times = randomRs (15, 20) $ _randGen w
     mF q z v size time = makeFlamelet q z v size time
     newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times