Broken commit (removed loadKeyConfig)

package.yaml

@@ -74,6 +74,11 @@ executables:
     - -funfolding-keeness-factor1000 
     - -fllvm 
     - -optlo-O3
+    - -Wall
+      #- -Wincomplete-uni-patterns
+    - -Widentities
+    - -Wredundant-constraints
+      #    - -Wmissing-export-lists
 #    - -fwrite-ide-info
 #    - -hiedir=.hie
     dependencies:

src/Dodge/Combine.hs

@@ -1,35 +1,37 @@
 module Dodge.Combine
+    (
+    )
     where
 --import Dodge.Data
-import Dodge.Combine.Data
+--import Dodge.Combine.Data
 
 --import qualified Data.IntMap.Strict as IM
 --import qualified Data.IntSet as IS
-import qualified Data.Map.Strict as M
+--import qualified Data.Map.Strict as M
 
 --combineList :: IM.IntMap Item -> [(Item , IS.IntSet)]
 --combineList 
 
 
-invert :: (Ord a) => M.Map b a -> M.Map a [b]
+--invert :: (Ord a) => M.Map b a -> M.Map a [b]
-invert = M.foldrWithKey (\k val -> M.insertWith (++) val [k]) M.empty
+--invert = M.foldrWithKey (\k val -> M.insertWith (++) val [k]) M.empty
-
+--
-combineList :: [([ItemType], ItemType)]
+--combineList :: [([ItemType], ItemType)]
-combineList =
+--combineList =
-    [ ( [ TPistol, TPipe, THardware ] , TRifle )
+--    [ ( [ TPistol, TPipe, THardware ] , TRifle )
-    , ( [ TRifle, THardware ] , TPistol )
+--    , ( [ TRifle, THardware ] , TPistol )
-    , ( [ TPistol, TPistol, THardware ] , TSpreadGun 2 )
+--    , ( [ TPistol, TPistol, THardware ] , TSpreadGun 2 )
-    , ( [ TSpreadGun 2, TPistol, THardware ] , TSpreadGun 3 )
+--    , ( [ TSpreadGun 2, TPistol, THardware ] , TSpreadGun 3 )
-    , ( [ TSpreadGun 3, TPistol, THardware ] , TSpreadGun 4 )
+--    , ( [ TSpreadGun 3, TPistol, THardware ] , TSpreadGun 4 )
-    , ( [ TSpreadGun 4, TPistol, THardware ] , TSpreadGun 5 )
+--    , ( [ TSpreadGun 4, TPistol, THardware ] , TSpreadGun 5 )
-    , ( [ TPistol, TAutoGun, THardware ]     , TLtAutoGun )
+--    , ( [ TPistol, TAutoGun, THardware ]     , TLtAutoGun )
-    , ( [ TLtAutoGun, TPipe, THardware ]     , TAutoGun )
+--    , ( [ TLtAutoGun, TPipe, THardware ]     , TAutoGun )
-    , ( [ TRifle, TRifle, THardware ] , TMultGun 2 )
+--    , ( [ TRifle, TRifle, THardware ] , TMultGun 2 )
-    , ( [ TMultGun 2, TRifle, THardware ] , TMultGun 3 )
+--    , ( [ TMultGun 2, TRifle, THardware ] , TMultGun 3 )
-    , ( [ TMultGun 3, TRifle, THardware ] , TMultGun 4 )
+--    , ( [ TMultGun 3, TRifle, THardware ] , TMultGun 4 )
-    , ( [ TMultGun 4, TRifle, THardware ] , TMultGun 5 )
+--    , ( [ TMultGun 4, TRifle, THardware ] , TMultGun 5 )
-    , ( [ TLtAutoGun, TPipe, THardware ]  , TAutoGun )
+--    , ( [ TLtAutoGun, TPipe, THardware ]  , TAutoGun )
-    , ( [ TPistol, TBigTube, THardware] , TLauncher 1 )
+--    , ( [ TPistol, TBigTube, THardware] , TLauncher 1 )
-    , ( [ TLauncher 1, TBigTube, TPistol, THardware] , TLauncher 2)
+--    , ( [ TLauncher 1, TBigTube, TPistol, THardware] , TLauncher 2)
-    , ( [ TLauncher 2, TBigTube, TPistol, THardware] , TLauncher 3)
+--    , ( [ TLauncher 2, TBigTube, TPistol, THardware] , TLauncher 3)
-    ]
+--    ]

src/Dodge/Combine/Data.hs

@@ -1,4 +1,6 @@
 module Dodge.Combine.Data
+    (ItemType (..)
+    )
     where
 data ItemType
     = TPipe

src/Dodge/Config/KeyConfig.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE DeriveGeneric #-}
 --{-# LANGUAGE OverloadedStrings #-}
 module Dodge.Config.KeyConfig
+    ( KeyConfigSDL (..)
+    , defaultKeyConfigSDL 
+    )
   where
 --import Data.Aeson
 --import Foreign.C.Types
@@ -10,26 +13,6 @@ import qualified SDL
 --import qualified SDL.Internal.Numbered
 --import System.Directory
 
-data KeyConfig = KeyConfig
-  { moveUpBinding :: Int,
-    moveDownBinding :: Int,
-    moveLeftBinding :: Int,
-    moveRightBinding :: Int,
-    pauseBinding :: Int,
-    escapeBinding :: Int,
-    dropItemBinding :: Int,
-    toggleMapBinding :: Int,
-    reloadBinding :: Int,
-    testEventBinding :: Int,
-    spaceActionBinding :: Int,
-    rotateCameraPlusBinding :: Int,
-    rotateCameraMinusBinding :: Int,
-    zoomInBinding :: Int,
-    zoomOutBinding :: Int,
-    newBinding :: Int
-  }
-  deriving (Generic, Show)
-
 data KeyConfigSDL = KeyConfigSDL
   { moveUpKey :: SDL.Scancode
   , moveDownKey :: SDL.Scancode
@@ -72,86 +55,3 @@ defaultKeyConfigSDL =
     , newMapKey = SDL.ScancodeN
     , modifierKey = SDL.ScancodeCapsLock
     }
-
---instance ToJSON KeyConfig where
---  toEncoding = genericToEncoding defaultOptions
---
---instance FromJSON KeyConfig where
---  parseJSON = withObject "KeyConfig" $ \o -> do
---    moveUpBinding <- o .:? "moveUp" .!= 119
---    moveDownBinding <- o .:? "moveDown" .!= 115
---    moveLeftBinding <- o .:? "moveLeft" .!= 97
---    moveRightBinding <- o .:? "moveRight" .!= 100
---    pauseBinding <- o .:? "pause" .!= 112
---    escapeBinding <- o .:? "escape" .!= 27
---    dropItemBinding <- o .:? "dropItem" .!= 102
---    toggleMapBinding <- o .:? "toggleMap" .!= 109
---    reloadBinding <- o .:? "reload" .!= 114
---    testEventBinding <- o .:? "testEvent" .!= 116
---    spaceActionBinding <- o .:? "spaceAction" .!= 32
---    rotateCameraPlusBinding <- o .:? "rotateCameraPlus" .!= 113
---    rotateCameraMinusBinding <- o .:? "rotateCameraMinus" .!= 101
---    zoomInBinding <- o .:? "zoomIn" .!= 106
---    zoomOutBinding <- o .:? "zoomOut" .!= 107
---    newBinding <- o .:? "new" .!= 110
---    return
---      KeyConfig
---        { moveUpBinding = moveUpBinding,
---          moveDownBinding = moveDownBinding,
---          moveLeftBinding = moveLeftBinding,
---          moveRightBinding = moveRightBinding,
---          pauseBinding = pauseBinding,
---          escapeBinding = escapeBinding,
---          dropItemBinding = dropItemBinding,
---          toggleMapBinding = toggleMapBinding,
---          reloadBinding = reloadBinding,
---          testEventBinding = testEventBinding,
---          spaceActionBinding = spaceActionBinding,
---          rotateCameraPlusBinding = rotateCameraPlusBinding,
---          rotateCameraMinusBinding = rotateCameraMinusBinding,
---          zoomInBinding = zoomInBinding,
---          zoomOutBinding = zoomOutBinding,
---          newBinding = newBinding
---        }
-
-loadKeyConfig :: IO KeyConfigSDL
-loadKeyConfig = return defaultKeyConfigSDL
-
---loadKeyConfig' :: IO KeyConfigSDL
---loadKeyConfig' = do
---    fExists <- doesFileExist "keys.json"
---    if fExists
---    then do
---        mayConfig <- decodeFileStrict "keys.json"
---        print mayConfig
---        case mayConfig of
---          Just config ->
---            return
---              KeyConfigSDL
---                { moveUpKey = getSdlScancode $ moveUpBinding config,
---                  moveDownKey = getSdlScancode $ moveDownBinding config,
---                  moveLeftKey = getSdlScancode $ moveLeftBinding config,
---                  moveRightKey = getSdlScancode $ moveRightBinding config,
---                  pauseKey = getSdlScancode $ pauseBinding config,
---                  escapeKey = getSdlScancode $ escapeBinding config,
---                  dropItemKey = getSdlScancode $ dropItemBinding config,
---                  toggleMapKey = getSdlScancode $ toggleMapBinding config,
---                  reloadKey = getSdlScancode $ reloadBinding config,
---                  testEventKey = getSdlScancode $ testEventBinding config,
---                  spaceActionKey = getSdlScancode $ spaceActionBinding config,
---                  rotateCameraPlusKey = getSdlScancode $ rotateCameraPlusBinding config,
---                  rotateCameraMinusKey = getSdlScancode $ rotateCameraMinusBinding config,
---                  zoomInKey = getSdlScancode $ zoomInBinding config,
---                  zoomOutKey = getSdlScancode $ zoomOutBinding config,
---                  newKey = getSdlScancode $ newBinding config
---                }
---          Nothing -> do
---            putStrLn "invalid keys.json, loading default config"
---            -- This is duplicated but not sure how to reduce
---            return defaultKeyConfigSDL
---    else do
---        putStrLn "No keys.json found, loading default config"
---        return defaultKeyConfigSDL
---
---getSdlScancode :: Int -> SDL.Scancode
---getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode

src/Dodge/Creature/AlertLevel/Data.hs

@@ -1,7 +1,13 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.Creature.AlertLevel.Data
-    where
+    ( AwakeLevel (..)
+    , AttentionDir (..)
+    , AwarenessLevel (..)
+    -- lenses
+    , getAttentiveTo
+    , getFixated
+    ) where
 import Control.Lens
 
 data AwakeLevel
@@ -12,8 +18,8 @@ data AwakeLevel
     | Overstrung
 
 data AttentionDir
-    = AttentiveTo {_unAttentiveTo :: [Int]}
+    = AttentiveTo {_getAttentiveTo :: [Int]}
-    | Fixated {_unFixated :: Int }
+    | Fixated {_getFixated :: Int }
 
 data AwarenessLevel
     = AwarenessInt Int

src/Dodge/Creature/Rationality.hs

@@ -87,7 +87,7 @@ followImpulse cr w imp = case imp of
     posFromID cid = _crPos $ _creatures w IM.! cid
     rr a = fst $ randomR (-a,a) $ _randGen w
     hitCr i = over (creatures . ix i . crState . crDamage) (addDam i)
-        . soundOnce (fromIntegral hitSound)
+        . soundOnce hitSound
     addDam i dams = Blunt 100 cpos (posFromID i) (posFromID i) : dams 
 
 actionUpdateAI

src/Dodge/Graph.hs

@@ -1,12 +1,16 @@
 module Dodge.Graph
-  where
+    ( pairsToSCC
+    , incidenceToFunction
+    , pairsToIncidence
+    ) where
+-- this deserves tests
 import Data.List.Extra
 
 import Data.Bifunctor (first)
 import Data.Graph
 import Data.Maybe
 
-pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
+pairsToIncidence :: Ord a => [(a,a)] -> [(a,[a])]
 pairsToIncidence 
     = map (first head . unzip)
     . groupOn fst
@@ -18,5 +22,5 @@ incidenceToFunction xs a = fromMaybe [] $ lookup a xs
 mkNode :: (a,[a]) -> (a,a,[a])
 mkNode (x,xs) = (x,x,xs)
 
-pairsToSCC :: (Eq a, Ord a) => [(a,a)] -> [SCC a]
+pairsToSCC :: Ord a => [(a,a)] -> [SCC a]
 pairsToSCC = stronglyConnComp . map mkNode . pairsToIncidence

src/Dodge/Item/Weapon.hs

@@ -275,7 +275,7 @@ hvAutoGun = defaultAutoGun
     , _wpAmmo = hvBullet
     }
   where 
-    mkHvBul it = withSound (fromIntegral longGunSound)
+    mkHvBul it = withSound longGunSound
         . withThinSmoke
         . withMuzFlare
         $ useAmmoParams it
@@ -322,21 +322,24 @@ miniGun = defaultAutoGun
     , _wpReloadTime = 200
     , _wpReloadState = 0
     , _wpMaxWarmUp = 100
-    , _itUseRate = 2
+    , _itUseRate = 1
     , _itUseTime = 0
-    , _itUse = \_ -> withWarmUp 50 
+    , _itUse = \it -> withWarmUp 26
         . shootWithSoundFor 28 2
-        . torqueBefore 0.03 . withSidePush 50 . withRecoil 15
+        . torqueBefore 0.1 
-        . withRandomDir 0.1
+--        . torqueBefore 0.03 
+        . withSidePush 50 
+        . withRecoil 15
+--        . withRandomDir 0.1
         . withRandomOffset 9
         . withMuzFlare
-        . withVelWthHiteff (V2 30 0) 2 
+        $ useAmmoParams it
-        $ destroyOnImpact bulBounceArmCr' bulHitWall' bulHitFF'
     , _wpRange = 20
     , _itFloorPict = onLayer FlItLayer miniGunPict
     , _itAimingSpeed = 0.4
     , _itAimingRange = 1
     , _itEquipPict = pictureWeaponOnAim miniGunPict
+    , _wpAmmo = basicBullet
     }
 miniGunPict :: Picture
 miniGunPict = pictures
@@ -354,7 +357,7 @@ spreadGun = defaultGun
     , _wpReloadState = 0
     , _itUseRate = 20
     , _itUseTime = 0
-    , _itUse = \_ -> shootWithSound (fromIntegral shotgunSound) 
+    , _itUse = \_ -> shootWithSound shotgunSound 
         . withRecoil 100
         . withMuzFlare
         $ spreadNumVelWthHiteff spreadGunSpread 9 (V2 30 0) 2 basicBulletEffect
@@ -375,7 +378,7 @@ multGun = defaultGun
     , _wpReloadState = 0
     , _itUseRate = 20
     , _itUseTime = 0
-    , _itUse = \_ -> shootWithSound (fromIntegral shotgunSound)
+    , _itUse = \_ -> shootWithSound shotgunSound
         . withRecoil 200
         . withMuzFlare
         $ numVelWthHitEff 5 (V2 50 0) 5 basicBulletEffect
@@ -411,7 +414,7 @@ longGun = defaultGun
     , _wpReloadType = PassiveReload skwareFadeTwoSecSound
     , _itUseRate = 100
     , _itUseTime = 0
-    , _itUse = shootWithSound (fromIntegral longGunSound)
+    , _itUse = shootWithSound longGunSound
         . withThickSmoke
         . torqueAfter 0.05
         . withMuzFlare
@@ -640,10 +643,10 @@ moveRemoteBomb itid time pID w
                 $ set (projectiles .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (f time) pID)
                     w
     | time < 2 = case hitWl of
-            Just _ -> soundOnce (fromIntegral tapQuiet) $ halfV updatedWorld
+            Just _ -> soundOnce tapQuiet $ halfV updatedWorld
             _      -> halfV updatedWorld
     | otherwise = case hitWl of
-            Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld
+            Just _ -> soundOnce tapQuiet updatedWorld
             _      -> updatedWorld
   where 
     updatedWorld 
@@ -757,7 +760,7 @@ fireRemoteLauncher :: Creature -> World -> World
 fireRemoteLauncher cr w = setLocation 
     $ resetFire 
     $ resetName 
-    $ soundOnce (fromIntegral launcherSound)
+    $ soundOnce launcherSound
     $ over projectiles remRocket w
   where
     i = IM.newKey $ _projectiles w
@@ -805,7 +808,7 @@ moveRemoteShell cid itid pj w
                 ( ( pjVel %~ ( (accel +.+) . (frict *.*) ) )
                 . ( pjDir .~ newdir )
                 )
-            & soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) 1 250
+            & soundFromPos (ShellSound i) newPos smokeTrailSound 1 250
             & smokeGen
             & makeFlameletTimed oldPos 20 (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
     | time > -200 = case thingHit of

src/Dodge/Item/Weapon/AutoGun.hs

@@ -49,10 +49,10 @@ autoGun = defaultAutoGun
     , _wpAmmo = basicBullet    
     }
 autoFireMode, singleFireMode, autoGunNonTwistEff :: Creature -> World -> World
-autoFireMode = shootWithSound (fromIntegral autoGunSound) 
+autoFireMode = shootWithSound autoGunSound
     . torqueBefore 0.05
     $ autoGunNonTwistEff
-singleFireMode = hammerCheck $ shootWithSound (fromIntegral autoGunSound) autoGunNonTwistEff
+singleFireMode = hammerCheck $ shootWithSound autoGunSound autoGunNonTwistEff
 autoGunNonTwistEff = withRecoil 40
     . withRandomDir (autogunSpread/2)
     . withMuzFlare

src/Dodge/Item/Weapon/Grenade.hs

@@ -32,7 +32,7 @@ moveGrenade 0 _ pID w = over projectiles (IM.delete pID)
     pj = _projectiles w IM.! pID
     explosion = _pjPayload pj
 moveGrenade time dir pID w = case hitWl of
-    Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld
+    Just _ -> soundOnce tapQuiet updatedWorld
     _      -> updatedWorld
   where 
     updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos

src/Dodge/Item/Weapon/Launcher.hs

@@ -37,7 +37,7 @@ launcher = defaultGun
     , _wpReloadState = 0
     , _itUseRate = 20
     , _itUseTime = 0
-    , _itUse = shootWithSound (fromIntegral launcherSound) . aRocketWithItemParams
+    , _itUse = shootWithSound launcherSound . aRocketWithItemParams
     , _wpSpread = 0.02
     , _wpRange = 20
     , _itFloorPict = onLayer FlItLayer launcherPic
@@ -92,14 +92,14 @@ pjThrust :: Int -> Projectile -> World -> World
 pjThrust i = pjEffTimeRange (st,et) doThrust
   where
     et | i == 0 = 36
-       | otherwise = 40 - (fromIntegral i * 20)
+       | otherwise = 40 - (i * 20)
     st = et - 100
 
 doThrust :: Projectile -> World -> World
 doThrust pj w = w
     & randGen .~ g
     & projectiles . ix i . pjVel    %~ (\v -> accel +.+ frict *.* v)
-    & soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) 1 250
+    & soundFromPos (ShellSound i) newPos smokeTrailSound 1 250
     & makeFlameletTimed (oldPos -.- vel) 0 (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
     & smokeGen
   where

src/Dodge/Item/Weapon/TriggerType.hs

@@ -83,22 +83,21 @@ rateIncAB startRate fastRate shooteff1 shooteff2 cr w
 Shoot a weapon rapidly after a warm up.
 Applies ammo check as well.  -}
 withWarmUp 
-    :: Int  -- ^ Warm up time (in frames)
+    :: Int -- ^ warm up sound id
     -> (Creature -> World -> World) 
-            -- ^ Shoot effect
+            -- ^ underlying effect
     -> Creature
     -> World 
     -> World
-withWarmUp t f cr w
+withWarmUp soundID f cr w
     | reloadCondition = fromMaybe w $ startReloadingWeapon cr w
     | _wpReloadState item /= 0 = w
     | curWarmUp < maxWarmUp = w
         & pointerToItem . wpCurWarmUp +~ 2
-        & soundFrom (CrWeaponSound cid) 26 2 0
+        & soundFrom (CrWeaponSound cid) soundID 2 0
     | otherwise = w
         & pointerToItem . wpCurWarmUp .~ maxWarmUp
         & f cr
---        & soundFrom (CrWeaponSound cid) 28 2 0
   where 
     cid = _crID cr
     itRef = _crInvSel cr
@@ -106,7 +105,6 @@ withWarmUp t f cr w
     pointerToItem = creatures . ix cid . crInv . ix itRef
     curWarmUp = _wpCurWarmUp item
     maxWarmUp = _wpMaxWarmUp item
-    fState = _itUseTime item
     reloadCondition = _wpLoadedAmmo item == 0
 {- | Adds a sound to a creature based world effect. 
 The sound is emitted from the creature's position. -}

src/Dodge/LevelGen/Data.hs

@@ -1,7 +1,22 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.LevelGen.Data
-    where
+    ( PSType (..)
+    , PlacementSpot (..)
+    , Placement (..)
+    , sPS
+    -- lenses
+    , placementSpot
+    , psType
+    , psPos
+    , psRot
+    , putID
+    , pwPoly
+    , pwWall
+    , unPutCrit
+    , groupPlacementID
+    , groupUpdate
+    ) where
 import Dodge.Data
 import Picture
 import Polyhedra.Data
@@ -36,9 +51,7 @@ data Placement
     = SinglePlacement {_placementSpot :: PlacementSpot }
     | GroupedPlacement
         {_groupPlacementID :: Int
---        ,_groupPlacementUpdate :: World -> Placement -> (World, Placement)
         ,_groupUpdate :: World -> [Placement] -> World
---        ,_groupPlacementFunc :: [PSType] -> PSType -> World -> World
         ,_placementSpot :: PlacementSpot
         }
 sPS :: Point2 -> Float -> PSType -> Placement

src/Dodge/LevelGen/MoveDoor.hs

@@ -65,7 +65,7 @@ addSoundToDoor i pld hwd (x:ys) = f x : ys
       where
         g dm w 
             | dist wp pld > 2 && dist wp hwd > 2 
-                        = soundFrom (WallSound i) (fromIntegral doorSound) 1 0 $ dm w
+                        = soundFrom (WallSound i) doorSound 1 0 $ dm w
             | otherwise = dm w
           where 
             wp = snd $ _wlLine (_walls w IM.! i)

src/Dodge/LevelGen/Pathing.hs

@@ -12,7 +12,7 @@ import qualified Data.IntMap.Strict as IM
 import Data.Graph.Inductive hiding ((&))
 --import Data.Graph.Inductive.NodeMap
 
-pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
+pairsToGraph :: (Ord 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

src/Dodge/Lock.hs

@@ -1,2 +0,0 @@
-module Dodge.Lock
-    where

src/Dodge/Lock/Data.hs

@@ -1,15 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE StrictData #-}
-module Dodge.Lock.Data
-    where
-import Dodge.Data
-import Control.Lens
-
-newtype Lock = Lock
-    { _lkUnlocker :: Unlocker
-    }
-
-newtype Unlocker
-    = ItemUnlocker Item
-
-makeLenses ''Lock

src/Dodge/Room/CheckConsistency.hs

@@ -13,5 +13,5 @@ linksOnPath r = all pointOnPath linkPoints
 pathConnected :: Room -> Bool
 pathConnected = isSingleton . pairsToSCC . _rmPath
   where
-    isSingleton [] = True
+    isSingleton [_] = True
     isSingleton _  = False

src/Dodge/Room/Data.hs

@@ -1,14 +1,20 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.Room.Data
-  where
+    ( Room (..)
+    , rmPolys
+    , rmLinks
+    , rmPath
+    , rmPS
+    , rmBound
+    , rmFloor
+    ) where
 import Dodge.LevelGen.Data
 --import Geometry
 import Geometry.Data
 import Data.Tile
 
 import Control.Lens
-
 {- 
 The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room.
 Link pairs contain a position and rotation to attach to another room;

src/Dodge/Room/Link.hs

@@ -33,8 +33,7 @@ randomiseAllLinks r = do
     return $ r {_rmLinks = newLinks}
 
 randomiseLinksBy 
-    :: RandomGen g 
+    :: ( [(Point2,Float)] -> State g [(Point2,Float)] )
-    => ( [(Point2,Float)] -> State g [(Point2,Float)] )
     -> Room
     -> State g Room
 randomiseLinksBy f r = do

src/Dodge/Room/Procedural.hs

@@ -231,8 +231,7 @@ randomFourCornerRoom = do
 {- | Creates room with a central vault with doors around it.
 -}
 centerVaultRoom
-    :: RandomGen g 
+    :: Int      -- ^ Door id
-    => Int      -- ^ Door id
     -> Float    -- ^ Width
     -> Float    -- ^ Height
     -> Float    -- ^ Vault dimensions

src/Dodge/Room/RoadBlock.hs

@@ -51,7 +51,7 @@ litCorridor90 = do
         , _rmBound = [poly]
         }
 
-noWeaponTest :: RandomGen g => State g (Tree (Either Room Room))
+noWeaponTest :: State g (Tree (Either Room Room))
 noWeaponTest = do
     undefined
 

src/Dodge/Room/Treasure.hs

@@ -14,7 +14,7 @@ import Geometry
 --import Data.List
 import Control.Monad.State
 --import Control.Lens
-import System.Random 
+--import System.Random 
 {- | A triangular room with loot at the top (with 'PutID' 2), 
 creatures in the bottom two corners (with 'PutID' 0), 
 and (single) entrance bottom middle.  -}
@@ -50,7 +50,7 @@ triLootRoom w h = pure $ defaultRoom
         ]
     base = rectNSWE 20 (-80) (-20) 20 
 {- | Create a random room with one entrance containing given creatures and items.  -}
-lootRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
+lootRoom :: [Creature] -> [Item] -> State g Room
 lootRoom crs itms = do
     let w = 300
         h = 700

src/Sound.hs

@@ -39,8 +39,8 @@ New sounds with the same keys as
 already playing sounds are merged as follows:
 
     * '_soundChannel' is set to the old value
-    * if the old '_soundStatus' was 'FadingOut', it is set to the new value (can restart playback with 'ToStart')
+    * if the old sound is not fading and the chunk is the same, '_soundStatus' is set to the old value 
-    * other fields are set to the new value.
+    * all other values are set to the new values
 
 In the update: 
     
@@ -51,18 +51,16 @@ In the update:
  -}
 playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound)
 playAndUpdate sData newSounds 
-    = updateSounds (_loadedChunks sData) (M.unionWith mergeSound newSounds (_playingSounds sData))
+    = updateSounds (_loadedChunks sData) (M.unionWith mergeSound (_playingSounds sData) newSounds)
 
 mergeSound :: Sound -> Sound -> Sound
-mergeSound newS oldS 
+mergeSound oldS newS
-    | _soundStatus oldS == FadingOut
+    | _soundChunkID newS == _soundChunkID oldS && _soundStatus oldS /= FadingOut
-                = newS & soundChannel .~ _soundChannel oldS
-    | _soundChunkID newS == _soundChunkID oldS
                 = newS & soundChannel .~ _soundChannel oldS
                        & soundStatus  .~ _soundStatus oldS
     | otherwise = newS & soundChannel .~ _soundChannel oldS
 
-updateSounds :: Ord a => IM.IntMap Mix.Chunk -> M.Map a Sound -> IO (M.Map a Sound)
+updateSounds :: IM.IntMap Mix.Chunk -> M.Map a Sound -> IO (M.Map a Sound)
 updateSounds sd ss = do
     may <- mapM (runMaybeT . updateSound sd) ss
     return $ M.mapMaybe id may

test/Spec.hs

@@ -1,4 +1,6 @@
 import Test.QuickCheck
+import Test.HUnit
+import Dodge.Room.CheckConsistency
 
 import Dodge.LevelGen.StaticWalls
 import Geometry
@@ -51,3 +53,5 @@ genTris = listOf genTri
   
 --
 --[[(0.0,1.0),(3.0,4.0),(5.0,5.0)],[(2.0,0.0),(2.0,4.0),(1.0,1.0)],[(5.0,5.0),(2.0,2.0),(1.0,3.0)]]
+--
+testRoom rm = TestCase "Room links connected" (linksOnPath rm)