Linting, haddocking

app/Main.hs

@@ -39,7 +39,7 @@ main = do
     dodgeConfig <- loadDodgeConfig
     setupLoop
         (sizex,sizey)
-        (SDL.cursorVisible $= False >> doPreload' dodgeConfig >>= resizeSpareFBO sizex sizey)
+        (SDL.cursorVisible $= False >> doPreload >>= applyWorldConfig dodgeConfig)
         (\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
         (fmap (setWindowSize sizex sizey keyConfig . (config .~ dodgeConfig)) firstWorld)
         doSideEffects
@@ -64,14 +64,13 @@ doSideEffects preData w = do
     foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
                     & frameTimer .~ endTicks)) (_doneSideEffects w)
 
-doPreload' :: Dodge.Config.Data.Configuration -> IO (PreloadData a)
+doPreload :: IO (PreloadData a)
-doPreload' config = do
+doPreload = do
     lChunks <- loadSounds
     lMusic  <- loadMusic
     let sData = SoundData {_loadedChunks = lChunks, _playingSounds = M.empty}
         mData = MusicData {_loadedMusic = lMusic}
     Mix.playMusic Mix.Forever (lMusic IM.! 0)
-    setVolume config
     rData <- preloadRender
     return $ PreloadData 
         { _renderData   = rData 
@@ -87,6 +86,6 @@ checkForGlErrors = do
 
 setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
 setWindowSize x y z w = w 
-    & windowX .~ fromIntegral x
+    & config . windowX .~ fromIntegral x
-    & windowY .~ fromIntegral y
+    & config . windowY .~ fromIntegral y
     & keyConfig .~ z

src/Dodge/Base.hs

@@ -3,6 +3,7 @@
 module Dodge.Base where
 -- imports {{{
 import Dodge.Data
+import Dodge.Config.Data
 
 import Geometry
 import Picture
@@ -52,8 +53,11 @@ 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
+halfWidth w = getWindowX w / 2
-halfHeight w = _windowY w / 2
+halfHeight w = getWindowY w / 2
+
+getWindowX = _windowX . _config
+getWindowY = _windowY . _config
 
 hasLOS :: Point2 -> Point2 -> World -> Bool
 {-# INLINE hasLOS #-}
@@ -317,7 +321,7 @@ zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
                  ]
     where (x,y) = zoneOfPoint $ _cameraCenter w
           n = ceiling $ wh / (_cameraZoom w * zoneSize)
-          wh = max (_windowX w) (_windowY w)
+          wh = max (getWindowX w) (getWindowY w)
 
 zoneOfDoubleScreen :: World -> [(Int,Int)]
 zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
@@ -325,7 +329,7 @@ zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
                  ]
     where (x,y) = zoneOfPoint $ _cameraCenter w
           n = (ceiling $ wh / (_cameraZoom w * zoneSize)) * 2
-          wh = max (_windowX w) (_windowY w)
+          wh = max (getWindowX w) (getWindowY w)
 
 zoneOfSight :: World -> [(Int,Int)]
 zoneOfSight w = [(a,b) | a <- [minimum xs .. maximum xs]
@@ -786,8 +790,8 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
     doTranslate p       =   p -.- _cameraCenter w
     doZoom p            =   _cameraZoom w *.* p
     doRotate p          =   rotateV (0 - _cameraRot w) p
-    doWindowScale (x,y) =   ( x * 2 / _windowX w
+    doWindowScale (x,y) =   ( x * 2 / getWindowX w
-                            , y * 2 / _windowY w
+                            , y * 2 / getWindowY w
                             )
 
 {- | Transform coordinates from the map position to normalised screen
@@ -799,8 +803,8 @@ cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
     doTranslate p       =   p -.- _carteCenter w
     doZoom p            =   _carteZoom w *.* p
     doRotate p          =   rotateV (0 - _carteRot w) p
-    doWindowScale (x,y) =   ( x * 2 / _windowX w
+    doWindowScale (x,y) =   ( x * 2 / getWindowX w
-                            , y * 2 / _windowY w
+                            , y * 2 / getWindowY w
                             )
 
 {- | The mouse position in world coordinates.

src/Dodge/Config/Data.hs

@@ -9,6 +9,8 @@ module Dodge.Config.Data (
     , volume_music
     , wall_textured
     , shadow_resolution
+    , windowX
+    , windowY
     ) where
 
 import Data.Aeson
@@ -24,7 +26,9 @@ data Configuration = Configuration
     , _volume_sound         :: Float
     , _volume_music         :: Float
     , _wall_textured        :: Bool
-    , _shadow_resolution :: Int -- ^ Higher values divide the screen size, i.e. make the resolution worse
+    , _shadow_resolution    :: Int -- ^ Higher values divide screen size, i.e. make the resolution worse
+    , _windowX              :: Float
+    , _windowY              :: Float
     }
   deriving (Generic, Show)
 
@@ -41,5 +45,7 @@ defaultConfig = Configuration
     , _volume_music         = 1
     , _wall_textured        = False
     , _shadow_resolution    = 1
+    , _windowX              = 800
+    , _windowY              = 600
     }
  

src/Dodge/Config/Update.hs

@@ -7,22 +7,39 @@ import Dodge.Data.SoundOrigin
 import Dodge.Config.Data
 import Sound
 import Preload.Data
+import Preload.Update
 
 import Data.Aeson (encodeFile)
 import Control.Monad (when)
 
+{- |
+Write the current world configuration to disk as a json file.
+ -}
 saveConfig :: Configuration -> PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)
 saveConfig cfig d = do
     putStrLn "Saving config to data/dodge.config.json"
     encodeFile "data/dodge.config.json" cfig
     return d
 
-setVolume :: Configuration -> IO ()
+{- |
-setVolume cfig = do
+Apply the volume settings from the world configuration to the running game.
-    setSoundVolume ( _volume_master cfig * _volume_sound cfig)
+ -}
-    setMusicVolume ( _volume_master cfig * _volume_music cfig)
-
 setVol :: Configuration -> PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)
 setVol cfig d = do
-    setVolume cfig
+    setSoundVolume ( _volume_master cfig * _volume_sound cfig)
+    setMusicVolume ( _volume_master cfig * _volume_music cfig)
     return d
+
+{- |
+Apply /all/ of the values in the world configuration to the running game.
+ -}
+applyWorldConfig
+    :: Configuration 
+    -> PreloadData SoundOrigin 
+    -> IO (PreloadData SoundOrigin)
+applyWorldConfig cfig pdata = do
+    setVol cfig pdata >>= resizeSpareFBO (x `div` divRes) (y `div` divRes)
+  where
+    x = round $ _windowX cfig
+    y = round $ _windowY cfig
+    divRes = _shadow_resolution cfig

src/Dodge/Creature/YourControl.hs

@@ -1,22 +1,21 @@
 module Dodge.Creature.YourControl
   where
-
 import Dodge.Data
 import Dodge.Base
 import Dodge.Creature.Action
 import Dodge.Creature.State
 import Dodge.Update.UsingInput
 import Dodge.Config.KeyConfig
-
+import Dodge.Item.Attachment.Data
 import Geometry
 
 import Control.Lens
 import qualified SDL
+import Data.Maybe
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import System.Random
 
-import Data.Maybe
 
 
 yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)

src/Dodge/Data.hs

@@ -24,6 +24,7 @@ import Dodge.Data.SoundOrigin
 import Dodge.Data.DamageType
 import Dodge.Config.Data
 import Dodge.Config.KeyConfig
+import Dodge.Item.Attachment.Data
 import Preload.Data
 import Picture.Data
 import Geometry.Data
@@ -82,8 +83,6 @@ data World = World
     , _menuLayers           :: [MenuLayer]
     , _worldState           :: M.Map WorldState Bool
     , _worldTriggers        :: S.Set WorldTrigger
-    , _windowX              :: !Float
-    , _windowY              :: !Float
     , _carteDisplay         :: !Bool
     , _carteCenter          :: !Point2
     , _carteZoom            :: !Float
@@ -303,18 +302,6 @@ data Item
         }
      | NoItem
 
-data ItAttachment 
-    = ItScope 
-        {_scopePos        :: Point2
-        ,_scopeZoomChange :: Int
-        ,_scopeZoom       :: Float 
-        ,_scopeIsCamera   :: Bool
-        }
-    | ItFuse {_itFuseTime :: Int}
-    | ItPhaseV {_itPhaseV :: Float}
-    | ItMode {_itMode :: Int}
-    | ItTargetPos { _itTargetPos :: Point2 }
-
 data ItEffect = NoItEffect
     | ItInvEffect 
         {_itInvEffect       :: Creature -> Int -> World -> World
@@ -496,7 +483,6 @@ makeLenses ''Stance
 makeLenses ''Item
 makeLenses ''ItemPos
 makeLenses ''ItEffect
-makeLenses ''ItAttachment
 makeLenses ''ItZoom
 makeLenses ''FloorItem
 makeLenses ''Projectile

src/Dodge/Data/Menu.hs

@@ -8,6 +8,6 @@ data MenuLayer
     | OptionMenu
     | SoundOptionMenu
     | GraphicsOptionMenu
-    | ConfigSaveScreen
     | ControlList
+    | WaitMessage String
   deriving (Eq,Ord)

src/Dodge/Default.hs

@@ -234,8 +234,6 @@ defaultWorld = World
     , _pathGraph' = []
     , _pathPoints = IM.empty
     , _pathInc = M.empty
-    , _windowX = 800
-    , _windowY = 600
     , _carteDisplay = False
     , _carteCenter = (0,0)
     , _carteZoom = 0.5

src/Dodge/Event.hs

@@ -47,8 +47,8 @@ handleEvent' e = case eventPayload e of
 
 handleMouseMotionEvent :: MouseMotionEventData -> World -> Maybe World
 handleMouseMotionEvent mmev w
-    = Just $ w & mousePos .~ (fromIntegral x - 0.5*_windowX w
+    = Just $ w & mousePos .~ (fromIntegral x - 0.5*getWindowX w
-                             ,0.5*_windowY w - fromIntegral y
+                             ,0.5*getWindowY w - fromIntegral y
                              )
     where P (V2 x y) = mouseMotionEventPos mmev
 
@@ -72,8 +72,8 @@ Resets the world window size, and resizes the fbo that gets the light map drawn
  -}
 handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
 handleResizeEvent sev w = Just 
-    . set windowX (fromIntegral x)
+    . set (config . windowX) (fromIntegral x)
-    . set windowY (fromIntegral y)
+    . set (config . windowY) (fromIntegral y)
     $ over sideEffects ( resizeSpareFBO (fromIntegral x `div` divRes) (fromIntegral y `div` divRes) : )
     w
   where 

src/Dodge/Event/Menu.hs

@@ -3,6 +3,7 @@ module Dodge.Event.Menu
     ) where
 import Dodge.Data
 import Dodge.Data.Menu
+import Dodge.Base
 import Dodge.Floor
 import Dodge.Initialisation
 import Dodge.SoundLogic
@@ -67,14 +68,14 @@ handlePressedKeyInMenu mState scode w = case mState of
     startNewGame = Just $ generateFromList levx 
         $ initialWorld 
             & randGen .~ _randGen w
-            & windowX .~ _windowX w
+            & config . windowX .~ getWindowX w
-            & windowY .~ _windowY w
+            & config . windowY .~ getWindowY w
 
 updateFramebufferSize :: World -> World
 updateFramebufferSize w = w & sideEffects 
     %~ (resizeSpareFBO (ceiling x `div` divRes) (ceiling y `div` divRes) : )
   where 
-    (x,y) = (_windowX w, _windowY w)
+    (x,y) = (getWindowX w, getWindowY w)
     divRes = w ^. config . shadow_resolution
 
 cycleResolution 1 = 2

src/Dodge/Floor.hs

@@ -41,7 +41,7 @@ roomTreex = do
     let t' = padCorridors struct
         t = treeFromTrunk 
                 [[StartRoom]
-                ,[Corridor]
+                ,[DoorAno]
                 ,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50]
                 ,[SpecificRoom blockedCorridor]
                 ,[OrAno [[DoorAno]

src/Dodge/Initialisation.hs

@@ -51,8 +51,6 @@ initialWorld = defaultWorld
                 , _storedLevel = Nothing
                 , _menuLayers = [LevelMenu 1]
                 , _worldState = M.empty
-                , _windowX = 800
-                , _windowY = 600
                 }
 
 

src/Dodge/Item/Attachment.hs

@@ -0,0 +1,2 @@
+module Dodge.Item.Attachment
+    where

src/Dodge/Item/Attachment/Data.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Item.Attachment.Data
+    where
+import Geometry.Data
+
+import Control.Lens
+
+data ItAttachment 
+    = ItScope 
+        {_scopePos        :: Point2
+        ,_scopeZoomChange :: Int
+        ,_scopeZoom       :: Float 
+        ,_scopeIsCamera   :: Bool
+        }
+    | ItFuse {_itFuseTime :: Int}
+    | ItPhaseV {_itPhaseV :: Float}
+    | ItMode {_itMode :: Int}
+    | ItCharMode 
+        {_itCharMode    :: Char
+        ,_itUpChar      :: Char -> Char
+        ,_itDownChar    :: Char -> Char
+        }
+    | ItTargetPos { _itTargetPos :: Point2 }
+
+makeLenses ''ItAttachment

src/Dodge/Item/Weapon.hs

@@ -21,6 +21,7 @@ import Dodge.Item.Weapon.Bullet
 import Dodge.Item.Weapon.InventoryDisplay
 import Dodge.Item.Weapon.TriggerType
 import Dodge.Item.Weapon.Recock
+import Dodge.Item.Attachment.Data
 import Geometry
 import Picture
 

src/Dodge/Item/Weapon/InventoryDisplay.hs

@@ -1,10 +1,21 @@
+{- |
+Display of weapon strings in the inventory.
+ -}
 module Dodge.Item.Weapon.InventoryDisplay
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Item.Attachment.Data
+
+import Control.Lens
+import Control.Monad
+
+-- MODES SHOULD BE MADE UNIFORM
 
 basicWeaponDisplay :: Item -> String
-basicWeaponDisplay it = midPadL 10 ' ' (_itName it) (' ' : aIfLoaded)
+basicWeaponDisplay it = case it ^? itAttachment . _Just . itCharMode of
+    Just c -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) ++ [' ',c]
+    otherwise -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded)
   where 
     availableAmmo = show $ _wpMaxAmmo it
     aIfLoaded = case (_wpReloadState it) of 

src/Dodge/Item/Weapon/Recock.hs

@@ -1,28 +1,36 @@
 {-# LANGUAGE BangPatterns #-}
+{- |
+Controls for continuous and non-continuous fire.
+ -}
 module Dodge.Item.Weapon.Recock
     where
 import Dodge.Data
 
 import Control.Lens
 import qualified Data.IntMap.Strict as IM
-
+{- |
+Controls resetting a weapon, allows for non-continuous fire needing a button release.  -}
 wpRecock :: ItEffect
-wpRecock = ItInvEffect {_itInvEffect = f
+wpRecock = ItInvEffect 
+    {_itInvEffect = f
     ,_itEffectCounter = 0
     }
-    where f cr i = creatures . ix (_crID cr) . crInv 
+  where 
-                           %~ IM.adjust fOnIt i
+    f cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust fOnIt i
-          moveHammerUp !HammerDown = HammerReleased
+    moveHammerUp HammerDown = HammerReleased
-          moveHammerUp !HammerReleased = HammerUp
+    moveHammerUp HammerReleased = HammerUp
-          moveHammerUp !HammerUp       = HammerUp
+    moveHammerUp HammerUp       = HammerUp
     fOnIt it = it & itHammer %~ moveHammerUp
-
+{- |
+Special recock for the bezier gun.
+Not sure of its purpose at this time...  -}
 bezierRecock :: ItEffect
-bezierRecock = ItInvEffect {_itInvEffect = f
+bezierRecock = ItInvEffect 
+    {_itInvEffect = f
     ,_itEffectCounter = 0
     }
-    where f cr i = creatures . ix (_crID cr) . crInv 
+  where 
-                           %~ IM.adjust fOnIt i
+    f cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust fOnIt i
     fOnIt it = case _itHammer it of
                   HammerDown -> it & itHammer .~ HammerUp
                   _          -> it & itAttachment .~ Nothing

src/Dodge/Item/Weapon/TriggerType.hs

@@ -1,6 +1,5 @@
-{-
+{- |
-Weapon effects when pulling the trigger.
+Weapon effects when pulling the trigger.  -}
- -}
 module Dodge.Item.Weapon.TriggerType
     where
 import Dodge.Data
@@ -10,6 +9,7 @@ import Dodge.WorldEvent (muzzleFlashAt,tempLightForAt)
 import Dodge.WorldEvent.Cloud
 import Dodge.RandomHelp
 import Dodge.Item.Weapon.Bullet
+import Dodge.Item.Attachment.Data
 import Geometry
 
 import System.Random
@@ -23,28 +23,27 @@ withThinSmoke
     -> Int      -- ^ Creature id
     -> World 
     -> World
-withThinSmoke eff cid w = eff cid . foldr makeThinSmokeAt w $ map (+.+ pos) ps
+withThinSmoke eff cid w = eff cid $ foldr (makeThinSmokeAt . (+.+ pos)) w ps
   where
     cr = _creatures w IM.! cid
     dir = _crDir cr
-          pos = _crPos cr +.+ ((_crRad cr +0.5) *.* unitVectorAtAngle dir)
+    pos = _crPos cr +.+ (_crRad cr +0.5) *.* unitVectorAtAngle dir
-          ps = (sequence . replicate 5 . randInCirc) 8 & evalState $ _randGen w
+    ps = (replicateM 5 . randInCirc) 8 & evalState $ _randGen w
 
 withThickSmoke 
     :: (Int -> World -> World) -- ^ Underlying effect
     -> Int      -- ^ Creature id
     -> World 
     -> World
-withThickSmoke eff cid w = eff cid . foldr makeThickSmokeAt w $ map (+.+ pos) ps
+withThickSmoke eff cid w = eff cid $ foldr (makeThickSmokeAt . (+.+ pos)) w ps
   where
     cr = _creatures w IM.! cid
     dir = _crDir cr
-          pos = _crPos cr +.+ ((_crRad cr +15) *.* unitVectorAtAngle dir)
+    pos = _crPos cr +.+ (_crRad cr + 15) *.* unitVectorAtAngle dir
-          ps = (sequence . replicate 20 . randInCirc) 8 & evalState $ _randGen w
+    ps = (replicateM 20 . randInCirc) 8 & evalState $ _randGen w
-
+{- |
-{- Shoot a weapon rapidly after a warm up.
+Shoot a weapon rapidly after a warm up.
-Applies ammo check as well.
+Applies ammo check as well.  -}
--}
 withWarmUp 
     :: Int  -- ^ Warm up time (in frames)
     -> (Int -> World -> World) 
@@ -79,9 +78,9 @@ withWarmUp t f cid w
     fState = _wpFireState item
     fRate = _wpFireRate item
     reloadCondition = _wpLoadedAmmo item == 0
-
+{- |
-{- Adds a sound to a creature based world effect. 
+Adds a sound to a creature based world effect. 
- The sound is emitted from the creature's position. -}
+The sound is emitted from the creature's position. -}
 withSound 
     :: Int -- ^ Sound id
     -> (Int -> World -> World) -- ^ Underlying effect
@@ -97,7 +96,7 @@ withRecoil
                 -- ^ Underlying world effect, takes creature id as input
     -> Int      -- ^ Creature id
     -> World -> World
-withRecoil recoilAmount eff cid w = eff cid . over (creatures . ix cid) pushback $ w
+withRecoil recoilAmount eff cid = eff cid . over (creatures . ix cid) pushback
   where 
     pushback cr = over crPos (+.+ rotateV (_crDir cr) ((-recoilAmount) / _crMass cr ,0)) cr
 
@@ -109,12 +108,10 @@ withSidePush
     -> World -> World
 withSidePush maxSide eff cid w = eff cid . over (creatures . ix cid) push $ w
   where 
-    push cr = over crPos (+.+ rotateV (_crDir cr) (0,(pushAmount) / _crMass cr)) cr
+    push cr = over crPos (+.+ rotateV (_crDir cr) (0,pushAmount / _crMass cr)) cr
     (pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
-
+{- |
-{- 
+Applies a world effect and sound effect after an ammo check. -}
-Applies a world effect and sound effect after an ammo check.
--}
 shootWithSound 
     :: Int  -- ^ Sound identifier
     -> (Int -> World -> World) 
@@ -129,7 +126,7 @@ shootWithSound soundid f cid w
     | reloadCondition = fromMaybe w $ reloadWeapon cid w
     | otherwise = w
   where 
-    cr  = (_creatures w IM.! cid)
+    cr  = _creatures w IM.! cid
     itRef = _crInvSel cr
     item = _crInv cr IM.! itRef
     pointerToItem = creatures . ix cid . crInv . ix itRef
@@ -137,19 +134,20 @@ shootWithSound soundid f cid w
                       && _wpFireState item == 0
                       && _wpLoadedAmmo item > 0
     reloadCondition = _wpLoadedAmmo item == 0
-{- Applies a world effect after an ammo check. -}
+{- | Applies a world effect after an ammo check. -}
 shoot 
     :: (Int -> World -> World) 
             -- ^ Underlying effect, takes creature id as input
     -> Int  -- ^ Creature id
     -> World -> World
-shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1) 
+shoot f cid w 
+    | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1) 
                           $ set (pointerToItem . wpFireState) (_wpFireRate item)
                           $ f cid w
     | reloadCondition = fromMaybe w $ reloadWeapon cid w
     | otherwise = w
   where 
-    cr  = (_creatures w IM.! cid)
+    cr  = _creatures w IM.! cid
     itRef = _crInvSel cr
     item = _crInv cr IM.! itRef
     pointerToItem = creatures . ix cid . crInv . ix itRef
@@ -158,15 +156,20 @@ shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> am
         && _wpLoadedAmmo item > 0
     reloadCondition = _wpLoadedAmmo item == 0
 
-withMuzFlare :: (Int -> World -> World) -> Int -> World -> World
+withMuzFlare 
+    :: (Int -> World -> World)  -- ^ Underlying effect
+    -> Int                      -- ^ Creature id
+    -> World 
+    -> World
 withMuzFlare f cid w = tempLightForAt 3 pos
                       . muzzleFlashAt pos2 $ f cid w
-    where cr = _creatures w IM.! cid
+  where 
+    cr = _creatures w IM.! cid
     dir = _crDir cr
     pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
     pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
 
-{-
+{- |
 Rotates the creature randomly, applies the effect, rotates the creature back.
 -}
 withRandomDir 
@@ -182,7 +185,7 @@ withRandomDir acc f cid w = over (creatures . ix cid . crDir) (\d -> d - a)
                             $ set randGen g
                               w
     where (a, g) = randomR (-acc,acc) $ _randGen w
-{- Creates a bullet with a given velocity, width, and 'HitEffect'
+{- | Creates a bullet with a given velocity, width, and 'HitEffect'
  -}
 withVelWthHiteff 
     :: Point2       -- ^ Velocity, x direction is forward with respect to the creature
@@ -200,7 +203,7 @@ withVelWthHiteff vel width hiteff cid w
     dir = _crDir cr
     pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
     pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
-{- Translate the creature sideways a random amount, apply the effect, translate back. -}
+{- | Translate the creature sideways a random amount, apply the effect, translate back. -}
 withRandomOffset 
     :: Float    -- ^ Max possible translate
     -> (Int -> World -> World)
@@ -229,36 +232,37 @@ torqueBeforeForced
     -> World 
     -> World
 torqueBeforeForced torque feff cid w 
-    | cid == 0  = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') 
+    | cid == 0  = feff cid $ w
-                                           $ over cameraRot (+rot') w
+        & randGen                    .~ g 
+        & creatures . ix cid . crDir +~ rot'
+        & cameraRot                  +~ rot'
     | otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') w
   where 
     (rot, g) = randomR (-torque,torque) $ _randGen w
     rot' | rot < 0   = rot - 0.1
          | otherwise = rot + 0.1
 
--- | Rotates the player creature before applying an effect, other creatures after.
+-- | Rotates the player creature before applying an effect.
+-- Note this currently (29/4/2021) rotates other creatures /after/ applying the effect.
 torqueBefore 
     :: Float                     -- ^ Max possible rotation
-    -> (Int -> World -> World) 
+    -> (Int -> World -> World)  -- ^ Underlying effect
-                -- ^ Underlying effect
+    -> Int                      -- ^ Creature id
-    -> Int 
-                -- ^ Creature id
     -> World 
     -> World
 torqueBefore torque feff cid w 
-    | cid == 0  = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) 
+    | cid == 0  = feff cid $ w
-                                           $ over cameraRot (+rot) w
+        & randGen                    .~ g 
-    | otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) w
+        & creatures . ix cid . crDir +~ rot
+        & cameraRot                  +~ rot
+    | otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) $ feff cid w
   where 
     (rot, g) = randomR (-torque,torque) $ _randGen w
 -- | Rotate a randomly creature after applying an effect.
 torqueAfter
     :: Float                    -- ^ Max possible rotation
-    -> (Int -> World -> World) 
+    -> (Int -> World -> World)  -- ^ Underlying effect
-                -- ^ Underlying effect
+    -> Int                      -- ^ Creature id
-    -> Int 
-                -- ^ Creature id
     -> World 
     -> World
 torqueAfter torque feff cid w 
@@ -268,7 +272,8 @@ torqueAfter torque feff cid w
     (rot, g) = randomR (-torque,torque) $ _randGen w
     rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
                           . itAttachment . _Just . scopePos %~ rotateV rot 
-{- Create multiple bullets with a given spread, a given amount, given velocity,
+{- |
+Create multiple bullets with a given spread, a given amount, given velocity,
 given width and given 'HitEffect'.
  -}
 spreadNumVelWthHiteff 
@@ -280,21 +285,20 @@ spreadNumVelWthHiteff
     -> Int      -- ^ Creature id
     -> World 
     -> World
-spreadNumVelWthHiteff spread num vel wth eff cid w 
+spreadNumVelWthHiteff spread num vel wth eff cid w = over particles (newbuls ++) w
-    = over particles (newbuls ++) w
   where 
     cr = _creatures w IM.! cid
-    newbuls = zipWith3 (\pos d colid -> aGenBulAt' (Just cid) (numColor colid) 
+    newbuls = zipWith3 
-                                              pos (rotateV d vel) eff wth
+        (\pos d colid -> aGenBulAt' (Just cid) (numColor colid) pos (rotateV d vel) eff wth) 
-                      ) poss dirs colids
+        poss dirs colids
     poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr))
-              $ evalState ((sequence . take num . repeat . randInCirc) 5) $ _randGen w
+              $ (replicateM num . randInCirc) 5 & evalState $ _randGen w
     dirs = map ((+) (_crDir cr)) 
-              $ zipWith (+) [-spread,-spread+(2*spread/(fromIntegral num))..]
+              $ zipWith (+) [-spread,-spread+(2*spread/fromIntegral num)..]
                             $ randomRs (0,spread/5) (_randGen w)
     colids = take num $ randomRs (0,11) (_randGen w)
-
+{- | 
-{- Create a number of bullets side by side with a given velocity,
+Create a number of bullets side by side with a given velocity,
 given width and given 'HitEffect'.
  -}
 numVelWthHitEff 
@@ -305,16 +309,15 @@ numVelWthHitEff
     -> Int      -- ^ Creature id
     -> World 
     -> World
-numVelWthHitEff  num vel wth eff cid w 
+numVelWthHitEff  num vel wth eff cid w = over particles (newbuls ++) w
-    = over particles (newbuls ++) w
   where 
     cr = _creatures w IM.! cid
-    newbuls = zipWith (\pos colid -> aGenBulAt' (Just cid) (numColor colid) 
+    newbuls = zipWith 
-                                                pos (rotateV d vel) eff wth
+        (\pos colid -> aGenBulAt' (Just cid) (numColor colid) pos (rotateV d vel) eff wth) 
-                      ) 
+        poss 
-                      poss colids
+        colids
     d = _crDir cr
-    poss = map (\o -> o +.+ pos) offsets
+    poss = map (+.+ pos) offsets
     maxOffset = fromIntegral num * 2.5 - 2.5
     offsets = map (\y -> rotateV d (0,y)) [-maxOffset,5-maxOffset..]
     colids = take num $ randomRs (0,11) (_randGen w)

src/Dodge/Layout/Tree/Annotate.hs

@@ -1,4 +1,4 @@
-{-
+{- |
 Annotating tree structures with desired properties for rooms.
 -}
 module Dodge.Layout.Tree.Annotate
@@ -43,38 +43,44 @@ addLock i t = do
     (beforeLock, afterLock) <- splitTrunk t
     newBefore <- applyToRandomNode (Key i :) beforeLock
     return $ addToTrunk newBefore [Node [Lock i] afterLock]
-
+{- |
+Add one corridor between each parent-child link of a tree of annotations.
+ -}
 padCorridors :: Tree [Annotation g] -> Tree [Annotation g]
 padCorridors (Node x xs) = Node [Corridor] [Node x (map padCorridors xs)]
-
+{-
+Add one to three corridors between each parent-child link of a tree of annotations.
+ -}
 randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
 randomPadCorridors  (Node x xs) = do
     n <- state $ randomR (1, 3)
     xs' <- mapM randomPadCorridors xs
     return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
-
+{- |
+Add a corridor to a random out-link of a room.
+ -}
 roomThenCorridor :: RandomGen g => Room -> State g (Tree (Either Room Room))
 roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r]) 
                                 (randomiseOutLinks corridor)
-
+{- |
-
+Create a random room tree structure from a list of annotations.
+ -}
 annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
 annoToRoomTree [OrAno as] = do
     a <- takeOne as
     annoToRoomTree a
-annoToRoomTree [Corridor] = fmap (pure . Right) $ randomiseOutLinks corridor
+annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
 annoToRoomTree [DoorAno] = roomThenCorridor door
 annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i)
 annoToRoomTree [FirstWeapon] = do
     branchWP <- branchRectWith weaponRoom
     blockedC <- longBlockedCorridor
-    firstWeapon <- takeOne $ [return $ appendEitherTree branchWP [blockedC]] ++ replicate 5 weaponRoom
+    join $ takeOne $ (return $ appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
-    firstWeapon
 annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
 annoToRoomTree [StartRoom] = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
-    fmap (pure . Right) $ randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
+    pure . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
 annoToRoomTree (SpecificRoom rt:_) = rt
 annoToRoomTree (BossAno cr : _) = branchRectWith . fmap (pure . Left) $ bossRoom cr
 annoToRoomTree (TreasureAno crs loot : _) =

src/Dodge/Layout/Tree/Either.hs

@@ -28,22 +28,20 @@ appendEitherTree
     :: Tree (Either a a)    -- ^ The first tree
     -> [Tree (Either a a)]    -- ^ The forest to append
     -> Tree (Either a a)
-appendEitherTree (Node (Left x) ts) ts'  = Node (Left x) $ map (flip appendEitherTree ts') ts
+appendEitherTree (Node (Left x) ts) ts'  = Node (Left x) $ map (`appendEitherTree` ts') ts
 appendEitherTree (Node (Right x) ts) ts' = Node (Left x) ts'
 
 removeEither (Left y)  = y
 removeEither (Right y) = y
 
-{- 
+{-  |
 Make a singleton connection of an Either Tree.
 -}
 connectRoom :: a -> Tree (Either a a)
 connectRoom r = Node (Right r) [] 
 
-{-
+{- |
 Make a singleton dead end of an Either Tree.
 -}
 deadRoom :: a -> Tree (Either a a)
 deadRoom r = Node (Left r) []
-
-

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -15,7 +15,7 @@ import Data.Tree
 import Control.Monad.State
 import System.Random
 
-{-
+{- |
 Creates a linear tree.
 Safe.
 -}
@@ -23,7 +23,7 @@ treeFromPost :: [a] -> a -> Tree a
 treeFromPost []     y = Node y []
 treeFromPost (x:xs) y = Node x [treeFromPost xs y]
 
-{-
+{- |
 Creates a tree with one trunk branch, 
 input as a list, that ends in another tree.
 -}
@@ -34,7 +34,7 @@ treeFromTrunk
 treeFromTrunk [] t     = t
 treeFromTrunk (x:xs) t = Node x [treeFromTrunk xs t]
 
-{-
+{- |
 Applies a function to the root of a tree.
 -}
 applyToRoot :: (a -> a) -> Tree a -> Tree a
@@ -42,7 +42,7 @@ applyToRoot f (Node t ts) = Node (f t) ts
 
 treeSize = length . flatten
 
-{-
+{- |
 Applies a function to a specific node determined by a list of indices.
 Unsafe (partial function).
 -}
@@ -52,7 +52,7 @@ applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs)
   where
     (ys, z:zs) = splitAt i xs
 
-{-
+{- |
 Applies a function to the first node along a trunk that satisfies a given property.
 -}
 applyToSubTrunkBy :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a
@@ -64,62 +64,65 @@ applyToSubTrunkBy _ _ t = t
 zipTree :: Tree a -> Tree b -> Tree (a,b)
 zipTree (Node x xs) (Node y ys) = Node (x,y) $ zipWith zipTree xs ys
 
-{-
+{- |
 Makes each node into its child number, i.e. the index it has 
 in the list of children of its parent.
 -}
 treeChildNums :: Tree a -> Tree Int
-treeChildNums t = setRoot 0 t
+treeChildNums = setRoot 0
   where 
     setRoot :: Int -> Tree a -> Tree Int
     setRoot i (Node x xs) = Node i (zipWith setRoot [0..] xs)
 
-{-
+{- |
 Makes each node into its path, i.e. the list of indices that, 
 when followed from the root, lead to the node.
 -}
 treePaths :: Tree a -> Tree [a]
-treePaths (Node x xs) = fmap (x :) $ Node [] (map treePaths xs)
+treePaths (Node x xs) = (x :) <$> Node [] (map treePaths xs)
 
-{-
+{- |
 Picks a random path in the tree.
 Uniform probability that the path leads to any specific node.
 -}
 randomPath :: RandomGen g => Tree a -> State g [Int]
 randomPath = takeOne . flatten . treePaths . treeChildNums
 
-{-
+{- |
-Apply a function to a node picked uniformly at random.
+Apply a function to the value of a node; 
+the node is picked uniformly at random.
 -}
 applyToRandomNode :: RandomGen g => (a -> a) -> Tree a -> State g (Tree a)
 applyToRandomNode f t = do
     p <- randomPath t
     return $ applyToNode p f t
 
-{-
+{- |
 Add a forest to the end of a tree (along the trunk).
 -}
 addToTrunk :: Tree a -> [Tree a] -> Tree a
 addToTrunk (Node x []) f = Node x f
 addToTrunk (Node x (t:ts)) f = Node x (addToTrunk t f : ts)
 
-{-
+{- |
 Find the depth of a tree along the trunk.
 -}
 trunkDepth :: Tree a -> Int
 trunkDepth (Node _ []) = 0
 trunkDepth (Node _ (x:xs)) = trunkDepth x + 1
 
-{-
+{- |
 Split a tree at a given point along its trunk.
 -}
-splitTrunkAt :: Int -> Tree a -> (Tree a, [Tree a])
+splitTrunkAt 
+    :: Int      -- ^ Split depth
+    -> Tree a -> (Tree a, [Tree a])
 splitTrunkAt 0 (Node x xs) = (Node x [],xs)
 splitTrunkAt i (Node y (x:xs)) = 
-    let (t, ts) = (splitTrunkAt (i-1) x)
+    let (t, ts) = splitTrunkAt (i-1) x
     in (Node y (t : xs) , ts)
 
-{-
+{- |
 Split a tree at a random point along its trunk.
 -}
 splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a])

src/Dodge/Layout/Tree/Shift.hs

@@ -1,3 +1,8 @@
+{- |
+Given a tree of rooms, tries to shift them into place in such a way that their
+links connect and that none of them clip.
+Returns a list; after this step the structure is determined by the actual positions of rooms.
+ -}
 module Dodge.Layout.Tree.Shift
     where
 import Dodge.Room.Data
@@ -11,21 +16,13 @@ import Data.List (delete)
 import Data.Maybe (listToMaybe)
 import Control.Lens hiding (Empty, (<|) , (|>))
 
-shiftRoomTreeConstruct :: [[Point2]] -> Tree Room -> Maybe (Tree Room)
+{- |
-shiftRoomTreeConstruct bs (Node t ts)
+Helper: Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
-    | roomIsClipping = Nothing
+ -}
-    | otherwise = case children of
+shiftRoomTreeSearch 
-        Nothing -> Nothing
+    :: [[Point2]]       -- ^ Clipping bounds
-        Just ts' -> Just $ Node t ts'
+    -> Seq (Tree Room)  -- ^ Rooms to be added
-  where
+    -> Maybe [Room]
-    roomIsClipping = any (polysIntersect (_rmBound t)) bs
-    children = sequence 
-             $ zipWith (\l -> shiftRoomTreeConstruct (_rmBound t : bs) 
-                                    . applyToRoot (shiftRoomToLink l))
-                       (_rmLinks t)
-                       ts
-
-shiftRoomTreeSearch :: [[Point2]] -> Seq (Tree Room) -> Maybe [Room]
 shiftRoomTreeSearch _  Empty = Just []
 shiftRoomTreeSearch bs (Node r ts :<| ts')
     | roomIsClipping = Nothing
@@ -36,13 +33,18 @@ shiftRoomTreeSearch bs (Node r ts :<| ts')
     children = fromList $ zipWith (\l -> applyToRoot (shiftRoomToLink l))
                        (_rmLinks r)
                        ts
-
+{- |
-shiftRoomTreeSearchAll :: [[Point2]] -> Seq (Tree Room) -> [[Room]]
+All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.
+ -}
+shiftRoomTreeSearchAll 
+    :: [[Point2]]       -- ^ Clipping bounds
+    -> Seq (Tree Room)  -- ^ Rooms to be added
+    -> [[Room]]
 shiftRoomTreeSearchAll _ Empty = [[]]
 shiftRoomTreeSearchAll bs (Node r ts :<| ts')
     | roomIsClipping = [] -- this is called too often, but whatever
     | otherwise = case ts of
-        [] -> (r :) <$> (shiftRoomTreeSearchAll newBounds $ ts')
+        [] -> (r :) <$> (shiftRoomTreeSearchAll newBounds ts')
         (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls
   where
     ls = init $ _rmLinks r
@@ -50,6 +52,8 @@ shiftRoomTreeSearchAll bs (Node r ts :<| ts')
     roomIsClipping = any (polysOverlap (_rmBound r)) bs
     rm l = r & rmLinks %~ delete l
     f l = applyToRoot (shiftRoomToLink l)
-
+{- |
+Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
+ -}
 shiftExpandTree :: Tree Room -> Maybe [Room]
 shiftExpandTree = listToMaybe . shiftRoomTreeSearchAll [] . singleton

src/Dodge/LevelGen/AutoDoor.hs

@@ -1,36 +1,50 @@
+{-
+Creation of doors that open when creatures approach them.
+ -}
 {-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.AutoDoor
     where
 import Dodge.Data
 import Dodge.Base
 import Dodge.SoundLogic
-
 import Dodge.Creature.Property
-
 import Geometry
 import Picture
 
 import Data.List
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
-
 import Control.Lens
 import Control.DeepSeq (deepseq)
 
-addAutoDoor :: Point2 -> Point2 -> World -> World
+addAutoDoor 
+    :: Point2   -- ^ Left point
+    -> Point2   -- ^ Right point (though the two points should be symmetric)
+    -> World 
+    -> World
 addAutoDoor a b = over walls (autoDoorAt a b)
 
-autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+autoDoorAt 
+    :: Point2   -- ^ Left point
+    -> Point2   -- ^ Right point (though the two points should be symmetric)
+    -> 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
+  where 
+    i = newKey wls
     is = [i..]
 
-mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
+mkAutoDoor 
+    :: Point2   -- ^ Left point
+    -> Point2   -- ^ Right point (though the two points should be symmetric)
+    -> [Int]    -- ^ Wall ids
+    -> [Wall]
 mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
                                xs
                                (lDoorClosed ++ rDoorClosed)
                                (map shiftL lDoorClosed ++ map shiftR rDoorClosed)
-    where lDoorClosed = [ [pld,hwd]
+  where 
+    lDoorClosed = [ [pld,hwd]
                   , [hwd,hwu]
                   , [hwu,plu]
                   ]
@@ -52,17 +66,22 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
 
     addSound (x:xs) = f x : xs
     f wl = over doorMech g wl
-          g dm w | dist wp pld > 1 && dist wp hwd > 1 
+    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
 
-autoDoorPane :: (Point2,Point2) -> Int -> [Point2] -> [Point2] -> Wall
+autoDoorPane 
+    :: (Point2,Point2)  -- ^ Trigger line
+    -> Int              -- ^ Wall id
+    -> [Point2]         -- ^ Closed position
+    -> [Point2]         -- ^ Open position
+    -> Wall
 autoDoorPane (trigx,trigy) n closedPos openPos = Door
     { _wlLine = closedPos
     , _wlID = n
     , _doorMech = dm
-    , _wlColor = dim $ yellow
+    , _wlColor = dim yellow
     , _wlSeen = False
     , _wlIsSeeThrough = False
     , _doorPathable = True
@@ -70,22 +89,18 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
   where 
     a = closedPos !! 0
     b = closedPos !! 1
-    dm w | any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
+    dm w 
---            crsNearLine 40 trigL w 
+        | any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
-                     = flip (foldr changeZonedWall) zoneps
+            = flip (foldr changeZonedWall) zoneps $ over walls (IM.adjust openDoor n) w
-                       $ over walls (IM.adjust openDoor n) w
+        | otherwise 
-         | otherwise = flip (foldr changeZonedWall') zoneps
+            = flip (foldr changeZonedWall') zoneps $ over walls (IM.adjust closeDoor n) w
-                       $ over walls (IM.adjust closeDoor n) w
     mvP !ep !p = mvPointTowardAtSpeed 2 ep p
     moveToward :: [Point2] -> Wall -> Wall
     moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
                        in deepseq newPs $ w {_wlLine = newPs}
-                        --deepseq ps $ w & wlLine %~ zipWith mvP ps
     openDoor  = moveToward openPos
     closeDoor = moveToward closedPos
     zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
            | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
-    changeZonedWall (!x,!y) 
+    changeZonedWall (!x,!y)  = over wallsZone $ adjustIMZone openDoor x y n
-          = over wallsZone $ adjustIMZone openDoor x y n
+    changeZonedWall' (!x,!y) = over wallsZone $ adjustIMZone closeDoor x y n
-    changeZonedWall' (!x,!y) 
-          = over wallsZone $ adjustIMZone closeDoor x y n

src/Dodge/LevelGen/Block.hs

@@ -1,127 +1,111 @@
-{-# LANGUAGE BangPatterns #-}
+{-
+Creation, update and descruction of destructible walls.
+ -}
 module Dodge.LevelGen.Block where
 import Dodge.Data
 import Dodge.Base
 import Dodge.SoundLogic
-
 import Dodge.WorldEvent.Sound
-
 import Dodge.LevelGen.Pathing
-
 import Geometry
 import Picture.Data
 
 import Control.Lens
-
+import Control.Monad.State
 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  
-   where  degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
+    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)
+      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
+    blockIsDead wl = case wl ^? blHP of 
+        Just x  -> x <= 0
         Nothing -> False
 
 killBlock :: Wall -> World -> World
-killBlock bl w =  f bl .
+killBlock bl w =  f bl .  flip (foldr unshadow) (_blShadows bl) $ w
-                  flip (foldr unshadow)
-                         (_blShadows bl)
-                        $ w
   where
     f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
     f bl          = hitSound' bl
     pos = _wlLine bl !! 0
-        hitSound bl | _wlIsSeeThrough bl = mkSoundBreakGlass pos
+    hitSound bl 
+        | _wlIsSeeThrough bl = mkSoundBreakGlass pos
         | otherwise = soundMultiFrom sos soundid 25 0 
-        hitSound' bl | _wlIsSeeThrough bl = mkSoundSplinterGlass pos
+    hitSound' bl 
+        | _wlIsSeeThrough bl = mkSoundSplinterGlass pos
         | 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)
+        Just b -> 
-                                       in  w & wallsZone . ix x . ix y . ix bid . blVisible %~ (\_ -> True)
+            let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
-                                             & walls . ix bid . blVisible %~ \_ -> True
+            in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True
+                 & walls . ix bid . blVisible %~ const True
         Nothing -> w
 
 degradeBlock :: Wall -> World -> World
-degradeBlock bl w = let blid = _wlID bl
+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
+{-
+This does not have clear behaviour in my mind, and should probably be replaced with something more obvious...
+ -}
+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))
+    xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
     let toAdd p' y = y *.* (p' -.- p)
     return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
 
-shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2]
+shrinkPolygon 
-shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps
+    :: RandomGen g 
+    => Float        -- ^ Shrink parameter
+    -> [Point2] 
+    -> State g [Point2]
+shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
 
-addBlockNoShadow :: [Point2] -> Int -> Color -> Bool -> [Int] -> Bool -> World -> World
+addBlock 
-addBlockNoShadow (p:ps) hp col isSeeThrough degradability hasAllShadows w 
+    :: [Point2]     -- ^ Block polygon
-    | hp <= 0 && degradability == [] = w
+    -> Int          -- ^ First layer of health
-    | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
+    -> Color 
-    | otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
+    -> Bool         -- ^ Is the block see through?
-      $ over walls (IM.union blocks) w
+    -> [Int]        -- ^ Extra layers of health
-  where 
+    -> World 
-        shadowList | hasAllShadows = repeat True
+    -> World
-                   | otherwise     = concat $ repeat [False,True]
-        lines = zip (p:ps) (ps ++ [p])
-        i = newKey $ _walls w
-        is = [i.. i + length lines-1]
-        blocks = IM.fromList $ zip is 
-                  $ zipWith3 (\j (a,b) bool 
-                                      -> Block { _wlLine = [a,b]
-                                               , _wlID = j
-                                            --   , _wlColor = greyN 0.5
-                                               , _wlColor = col
-                                               , _wlSeen = False
-                                               , _blIDs = is
-                                               , _blHP = hp
-                                               , _wlIsSeeThrough = isSeeThrough
-                                               , _blVisible = True
-                                               , _blShadows = []
-                                               , _blDegrades = degradability
-                                               }
-                             ) is lines shadowList
-        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)
-
-addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
 addBlock (p:ps) hp col isSeeThrough degradability w 
-    | hp <= 0 && degradability == [] = w
+    | hp <= 0 && null degradability = w
     | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
-    | otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
+    | otherwise = w  
-      $ over walls (IM.union blocks) w
+            & wallsZone %~ flip (IM.foldr wallInZone) panes
---addBlock (p:p':ps) w = over walls (IM.insert i b) w
+            & walls     %~ IM.union panes
   where 
     lines = zip (p:ps) (ps ++ [p])
     i = newKey $ _walls w
     is = [i.. i + length lines-1]
-        blocks = IM.fromList $ zip is 
+    panes = IM.fromList $ zip is 
               $ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
                                            , _wlID = j
-                                            --   , _wlColor = greyN 0.5
                                            , _wlColor = col
                                            , _wlSeen = False
                                            , _blIDs = is
@@ -132,18 +116,15 @@ addBlock (p:ps) hp col isSeeThrough degradability w
                                            , _blDegrades = degradability
                                            }
                          ) is lines
-        wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
+    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))
+      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)
         
-putBlockWallPart :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
-putBlockWallPart (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
-    where pairs = zip (p:ps) (ps ++ [p])
-          wWithBlock = addBlockNoShadow (p:ps) i c b is False w
-
 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])

src/Dodge/Render.hs

@@ -31,7 +31,7 @@ import qualified Data.Set as S
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import qualified SDL
 
-halfwindow = over windowX ( / 2) . over windowY ( / 2)
+halfwindow = over (config . windowX) ( / 2) . over (config . windowY) ( / 2)
 
 doDrawing :: RenderData -> World -> IO (Word32)
 doDrawing pdata w = do
@@ -40,7 +40,7 @@ doDrawing pdata w = do
     let rot     = _cameraRot w
         zoom    = _cameraZoom w
         trans@(tranx,trany) = _cameraCenter w
-        wins@(winx,winy)    = (_windowX w,_windowY w)
+        wins@(winx,winy)    = (getWindowX w,getWindowY w)
         wallPointsCol   = wallsPointsAndCols w
         windowPoints    = wallsWindows w
         lightPoints     = lightsForGloom' w

src/Dodge/Render/HUD.hs

@@ -23,7 +23,7 @@ hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $
     selectionText = if   _carteDisplay w
                     then drawLocations w
                     else drawInventory w
-    scaler = scale (2 / _windowX w) (2 / _windowY w)
+    scaler = scale (2 / getWindowX w) (2 / getWindowY w)
 
 drawInventory :: World -> [Picture]
 drawInventory w = 
@@ -42,7 +42,7 @@ displayListTopLeft scols w =
         ( map (\x -> halfHeight w - (20 * (fromIntegral x+1)))    [0..] )
         ( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
   where
-    scaler = scale (2 / _windowX w) (2 / _windowY w)
+    scaler = scale (2 / getWindowX w) (2 / getWindowY w)
 
 displayInv :: Int -> World -> [Picture]
 displayInv n w = displayListTopLeft scols w
@@ -78,14 +78,14 @@ displayListCoords :: World -> [Point2]
 displayListCoords w = map (g . f) [1..]
   where 
     f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) )
-    g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
+    g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
 
 displayListEndCoords :: World -> [String] -> [Point2]
 displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
   where 
     f :: Int -> Point2
     f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) )
-    g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
+    g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
     h :: String -> Point2 -> Point2
     h s (x,y) = (x + 9 * fromIntegral (length s), y)
 
@@ -107,16 +107,16 @@ mapWall w wl =
     (x:y:_) = _wlLine wl
     c = _wlColor wl
 
-{- Pictures of popup text for items close to your position.-}
+{- | Pictures of popup text for items close to your position.-}
 closeObjectTexts :: World -> Picture
 closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _closeActiveObjects w)
                                 ++ maybeToList maybeLine
   where 
     colAndText (Left x)  = (_itInvColor $ _flIt x, _itName $ _flIt x)
     colAndText (Right x) = (white, _btText x)
-    renderList i (c,t) = scale (2/_windowX w) (2/_windowY w)
+    renderList i (c,t) = scale (2/getWindowX w) (2/getWindowY w)
                          . tran
-                         . translate (xtran i) (0 - 20 * fromIntegral i)
+                         . translate (xtran i) (negate (20 * fromIntegral i))
                          . scale 0.1 0.1 
                          . color c 
                          $ text t
@@ -135,7 +135,7 @@ closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _clos
     objPos obj = case obj of Left flit -> _flItPos flit
                              Right bt  -> _btPos bt
     mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
-    sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
+    sc (x, y) = (x*2/getWindowX w, y*2/getWindowY w)
     maybeLine = do 
           itScreenPos <- mayScreenPos
           theText <- fmap (snd . colAndText) mayObj
@@ -153,7 +153,7 @@ closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _clos
                       ,(sc p       , col)
                       ]
 
-{- Add coloured drop shadow. -}
+{- | Add coloured drop shadow. -}
 dShadCol :: Color -> Picture -> Picture
 dShadCol c p = pictures
                 [ color black $ uncurry translate (1.2,-1.2) p
@@ -161,7 +161,7 @@ dShadCol c p = pictures
                 ]
 
 drawListCursor :: Color -> Int -> World -> Picture
-drawListCursor c iPos w = scale (2 / _windowX w) (2 / _windowY w)
+drawListCursor c iPos w = scale (2 / getWindowX w) (2 / getWindowY w)
     . translate (105-halfWidth w) (halfHeight w - (20* fromIntegral iPos) - 20)
                  $ lineCol [(( 100,12.5) ,withAlpha 0 c)
                            ,((-100,12.5) ,c)

src/Dodge/Render/MenuScreen.hs

@@ -50,13 +50,13 @@ menuScreen cfig hw hh mLays = case mLays of
         ,tst (-100) 100 0.4 "CONTROLS"
         ,controlsList
         ]
-    (ConfigSaveScreen : _) -> optionsList hw hh "SAVING..." []
+    (WaitMessage s : _) -> optionsList hw hh s []
     _ -> blank
   where 
     tst x y sc t = translate x y $ scale sc sc $ color white $ text t
-    mavol = f $ _volume_master $ cfig
+    mavol = f $ _volume_master cfig
-    snvol = f $ _volume_sound  $ cfig
+    snvol = f $ _volume_sound  cfig
-    muvol = f $ _volume_music  $ cfig
+    muvol = f $ _volume_music  cfig
     f x = show $ round $ 10 * x
     showShadRes i = "1/"++ show i
 

src/Dodge/Render/Picture.hs

@@ -34,12 +34,12 @@ fixedCoordPictures w = pictures
     , customMouseCursor w
     ]
   where 
-    scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w)
+    scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)
 
 customMouseCursor :: World -> Picture
 customMouseCursor w = 
     setDepth (-1)
-    . scale (2 /_windowX w) (2/ _windowY w) 
+    . scale (2 /getWindowX w) (2/ getWindowY w) 
     . uncurry translate (_mousePos w)
     $ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]
 

src/Dodge/Room/RoadBlock.hs

@@ -43,7 +43,7 @@ litCorridor90 = do
             [ PS (20,h-5) 0     putLamp
             , windowLine (0,h-20) (40,h-20)
             , PS (-50,h-85) 0   putLamp
-            , windowLine (0-40,h-60) (0-40,h-100)
+            , windowLine (-40,h-60) (-40,h-100)
             , PS ( 20,h-40) 0   $ PutID 0
             , PS (-20,h-80) 0   $ PutID 2
             ]
@@ -61,10 +61,10 @@ longBlockedCorridor = do
     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
-                 ,PS (20,15) 0 $ putLamp
+                 ,PS (20,15) 0 putLamp
                  ]
-    sequence $ treeFromPost (replicate n $ fmap Left $ randomiseOutLinks corridor) 
+    sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor) 
-                        $ fmap Right $ return $ set rmPS plmnts corridor
+                        $ return $ Right $ set rmPS plmnts corridor
 
 -- | A single corridor with a descrutible block blocking it.
 blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
@@ -72,7 +72,6 @@ blockedCorridor = do
     r <- state $ randomR (0,pi)
     let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256) 
                                           $ reverse $ rectNSWE 10 (-10) (-10) 10
-                 ,PS (20,15) 0 $ putLamp
+                 ,PS (20,15) 0 putLamp
                  ]
-    sequence $ treeFromPost [] 
+    sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
-                        $ fmap Right $ return $ set rmPS plmnts corridor

src/Dodge/Update.hs

@@ -7,6 +7,8 @@ module Dodge.Update
     ) where
 import Dodge.Data
 import Dodge.Data.Menu
+import Dodge.Config.Data
+import Dodge.Data.Menu
 import Dodge.Base
 import Dodge.WallCreatureCollisions
 import Dodge.LevelGen.Block
@@ -40,7 +42,7 @@ In such menus, the only way to change the world is using event handling.
  -}
 update' :: World -> World
 update' w = case _menuLayers w of
-    (ConfigSaveScreen : ls) -> w & menuLayers .~ ls
+    (WaitMessage _ : ls) -> w & menuLayers .~ ls
     (_ : _) -> w    
     []  ->  let w1 = updateParticles 
                     . updateProjectiles 
@@ -53,13 +55,13 @@ update' w = case _menuLayers w of
                     . updateSoundQueue
                     $ updateCloseObjects w
             in  checkEndGame 
-                    . triggerUpdate
+                    . updateTriggers
                     . ppEvents 
                     . updateCamera
                     . colCrsWalls
                     . simpleCrSprings 
                     . zoneCreatures 
-                    . wallEvents
+                    . updateWalls
                     . set worldEvents id 
                     $ _worldEvents w1 w1
   where 
@@ -72,16 +74,15 @@ update' w = case _menuLayers w of
       where (x,y) = zoneOfPoint $ _clPos cr
             cid = _clID cr
 
-triggerUpdate :: World -> World
+updateTriggers :: World -> World
-triggerUpdate w 
+updateTriggers w 
     | ResetLevel 1 `S.member` _worldTriggers w
         = generateFromList levx
             $ initialWorld 
                 & randGen       .~ _randGen w
-                & windowX .~ _windowX w
+                & config        .~ _config w
-                & windowY .~ _windowY w
                 & menuLayers    .~ []
-                & creatures . ix 0 .~ (_creatures w IM.! 0 & crPos .~ (0,0))
+                & creatures . ix 0 . crPos .~ (0,0)
     | otherwise = w
 
 updateSoundQueue = set soundQueue [] . set sounds M.empty
@@ -107,12 +108,11 @@ updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
     ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) 
                         $ _creatures w
 
-
+{- |
-wallEvents :: World -> World
+Apply door mechanisms.
-wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of 
+ -}
-                                                                Door {} -> True
+updateWalls :: World -> World
-                                                                BlockAutoDoor {} -> True
+updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w)
-                                                                _       -> False) ( _walls w))
 
 ppEvents :: World -> World
 ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w

src/Dodge/Update/Camera.hs

@@ -1,8 +1,7 @@
 {-
 Functions controlling the movement of the screen camera: 
 '_cameraCenter', '_cameraZoom', _cameraRot';
-and the position that the character sees from: '_cameraViewFrom'.
+and the position that the character sees from: '_cameraViewFrom'.  -}
--}
 module Dodge.Update.Camera 
     ( updateCamera
     ) 
@@ -10,6 +9,7 @@ module Dodge.Update.Camera
 import Dodge.Data
 import Dodge.Base
 import Dodge.Config.KeyConfig
+import Dodge.Item.Attachment.Data
 import Geometry
 
 import Control.Lens

src/Preload/Update.hs

@@ -18,8 +18,8 @@ resizeSpareFBO xsize ysize pdata = do
         fboName = _spareFBO rdata
         fboTO   = _fboTexture rdata
         fboRBO  = _fboRenderbufferObject rdata
-        xsize' = fromIntegral $ xsize
+        xsize' = fromIntegral xsize
-        ysize' = fromIntegral $ ysize
+        ysize' = fromIntegral ysize
     bindFramebuffer Framebuffer $= fboName
     textureBinding Texture2D $= Just fboTO
     texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D xsize' ysize') 0 (PixelData RGBA UnsignedByte nullPtr)

src/Shader/Data.hs

@@ -1,12 +1,12 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-
+{- |
 Datatypes used to setup and pass data to shaders.
 -}
 module Shader.Data
     ( VAO (..)
     , FullShader (..)
     , ShaderTexture (..)
--- lens functions
+-- | Lens functions
     , vao
     , vaoBufferTargets
 
@@ -23,14 +23,14 @@ module Shader.Data
 import Graphics.Rendering.OpenGL
 import Foreign
 import Control.Lens
-{- Vertex array object: contains the reference to the object,
+{- | Vertex array object: contains the reference to the object,
 and its buffer targets.
 -}
 data VAO = VAO
     { _vao :: VertexArrayObject
     , _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
     }
-{- 
+{- |
 Datatype containing the necessary information for a single shader.
 -}
 data FullShader a = FullShader
@@ -42,7 +42,7 @@ data FullShader a = FullShader
     , _shaderTexture :: Maybe ShaderTexture
     , _shaderCustomUnis :: Maybe [UniformLocation]
     }
-{-
+{- |
 Datatype containing the reference to a texture object.
 -}
 newtype ShaderTexture = ShaderTexture