From 3ff04576ab036f258397f6e64f3537841f3774d0 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 27 Aug 2021 11:58:11 +0100 Subject: [PATCH] Broken commit (removed loadKeyConfig) --- package.yaml | 5 ++ src/Dodge/Combine.hs | 50 ++++++------ src/Dodge/Combine/Data.hs | 2 + src/Dodge/Config/KeyConfig.hs | 106 +------------------------- src/Dodge/Creature/AlertLevel/Data.hs | 12 ++- src/Dodge/Creature/Rationality.hs | 2 +- src/Dodge/Graph.hs | 10 ++- src/Dodge/Item/Weapon.hs | 31 ++++---- src/Dodge/Item/Weapon/AutoGun.hs | 4 +- src/Dodge/Item/Weapon/Grenade.hs | 2 +- src/Dodge/Item/Weapon/Launcher.hs | 6 +- src/Dodge/Item/Weapon/TriggerType.hs | 10 +-- src/Dodge/LevelGen/Data.hs | 19 ++++- src/Dodge/LevelGen/MoveDoor.hs | 2 +- src/Dodge/LevelGen/Pathing.hs | 2 +- src/Dodge/Lock.hs | 2 - src/Dodge/Lock/Data.hs | 15 ---- src/Dodge/Room/CheckConsistency.hs | 2 +- src/Dodge/Room/Data.hs | 10 ++- src/Dodge/Room/Link.hs | 3 +- src/Dodge/Room/Procedural.hs | 3 +- src/Dodge/Room/RoadBlock.hs | 2 +- src/Dodge/Room/Treasure.hs | 4 +- src/Sound.hs | 14 ++-- test/Spec.hs | 4 + 25 files changed, 122 insertions(+), 200 deletions(-) delete mode 100644 src/Dodge/Lock.hs delete mode 100644 src/Dodge/Lock/Data.hs diff --git a/package.yaml b/package.yaml index b861882fc..223abdddd 100644 --- a/package.yaml +++ b/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: diff --git a/src/Dodge/Combine.hs b/src/Dodge/Combine.hs index 106b8b438..89c6ccd1a 100644 --- a/src/Dodge/Combine.hs +++ b/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 = M.foldrWithKey (\k val -> M.insertWith (++) val [k]) M.empty - -combineList :: [([ItemType], ItemType)] -combineList = - [ ( [ TPistol, TPipe, THardware ] , TRifle ) - , ( [ TRifle, THardware ] , TPistol ) - , ( [ TPistol, TPistol, THardware ] , TSpreadGun 2 ) - , ( [ TSpreadGun 2, TPistol, THardware ] , TSpreadGun 3 ) - , ( [ TSpreadGun 3, TPistol, THardware ] , TSpreadGun 4 ) - , ( [ TSpreadGun 4, TPistol, THardware ] , TSpreadGun 5 ) - , ( [ TPistol, TAutoGun, THardware ] , TLtAutoGun ) - , ( [ TLtAutoGun, TPipe, THardware ] , TAutoGun ) - , ( [ TRifle, TRifle, THardware ] , TMultGun 2 ) - , ( [ TMultGun 2, TRifle, THardware ] , TMultGun 3 ) - , ( [ TMultGun 3, TRifle, THardware ] , TMultGun 4 ) - , ( [ TMultGun 4, TRifle, THardware ] , TMultGun 5 ) - , ( [ TLtAutoGun, TPipe, THardware ] , TAutoGun ) - , ( [ TPistol, TBigTube, THardware] , TLauncher 1 ) - , ( [ TLauncher 1, TBigTube, TPistol, THardware] , TLauncher 2) - , ( [ TLauncher 2, TBigTube, TPistol, THardware] , TLauncher 3) - ] +--invert :: (Ord a) => M.Map b a -> M.Map a [b] +--invert = M.foldrWithKey (\k val -> M.insertWith (++) val [k]) M.empty +-- +--combineList :: [([ItemType], ItemType)] +--combineList = +-- [ ( [ TPistol, TPipe, THardware ] , TRifle ) +-- , ( [ TRifle, THardware ] , TPistol ) +-- , ( [ TPistol, TPistol, THardware ] , TSpreadGun 2 ) +-- , ( [ TSpreadGun 2, TPistol, THardware ] , TSpreadGun 3 ) +-- , ( [ TSpreadGun 3, TPistol, THardware ] , TSpreadGun 4 ) +-- , ( [ TSpreadGun 4, TPistol, THardware ] , TSpreadGun 5 ) +-- , ( [ TPistol, TAutoGun, THardware ] , TLtAutoGun ) +-- , ( [ TLtAutoGun, TPipe, THardware ] , TAutoGun ) +-- , ( [ TRifle, TRifle, THardware ] , TMultGun 2 ) +-- , ( [ TMultGun 2, TRifle, THardware ] , TMultGun 3 ) +-- , ( [ TMultGun 3, TRifle, THardware ] , TMultGun 4 ) +-- , ( [ TMultGun 4, TRifle, THardware ] , TMultGun 5 ) +-- , ( [ TLtAutoGun, TPipe, THardware ] , TAutoGun ) +-- , ( [ TPistol, TBigTube, THardware] , TLauncher 1 ) +-- , ( [ TLauncher 1, TBigTube, TPistol, THardware] , TLauncher 2) +-- , ( [ TLauncher 2, TBigTube, TPistol, THardware] , TLauncher 3) +-- ] diff --git a/src/Dodge/Combine/Data.hs b/src/Dodge/Combine/Data.hs index 696136385..efbb70242 100644 --- a/src/Dodge/Combine/Data.hs +++ b/src/Dodge/Combine/Data.hs @@ -1,4 +1,6 @@ module Dodge.Combine.Data + (ItemType (..) + ) where data ItemType = TPipe diff --git a/src/Dodge/Config/KeyConfig.hs b/src/Dodge/Config/KeyConfig.hs index 7a339cbc7..2b2363ef2 100644 --- a/src/Dodge/Config/KeyConfig.hs +++ b/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 diff --git a/src/Dodge/Creature/AlertLevel/Data.hs b/src/Dodge/Creature/AlertLevel/Data.hs index a181e9892..92dea986b 100644 --- a/src/Dodge/Creature/AlertLevel/Data.hs +++ b/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]} - | Fixated {_unFixated :: Int } + = AttentiveTo {_getAttentiveTo :: [Int]} + | Fixated {_getFixated :: Int } data AwarenessLevel = AwarenessInt Int diff --git a/src/Dodge/Creature/Rationality.hs b/src/Dodge/Creature/Rationality.hs index 0e92e4a13..d93224786 100644 --- a/src/Dodge/Creature/Rationality.hs +++ b/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 diff --git a/src/Dodge/Graph.hs b/src/Dodge/Graph.hs index 4c8efee7e..d68546d1f 100644 --- a/src/Dodge/Graph.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 238ce904c..61fffffee 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/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 - . withRandomDir 0.1 + . torqueBefore 0.1 +-- . torqueBefore 0.03 + . withSidePush 50 + . withRecoil 15 +-- . withRandomDir 0.1 . withRandomOffset 9 . withMuzFlare - . withVelWthHiteff (V2 30 0) 2 - $ destroyOnImpact bulBounceArmCr' bulHitWall' bulHitFF' + $ useAmmoParams it , _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 diff --git a/src/Dodge/Item/Weapon/AutoGun.hs b/src/Dodge/Item/Weapon/AutoGun.hs index 8e5c37e06..7c7faee5f 100644 --- a/src/Dodge/Item/Weapon/AutoGun.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index 9fc8933f0..f4b930d1b 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 814d3aa27..1cac73481 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 657bcfa9e..6da9c0d7c 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/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. -} diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 7a60f3904..c6ee39126 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/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 diff --git a/src/Dodge/LevelGen/MoveDoor.hs b/src/Dodge/LevelGen/MoveDoor.hs index 39fe39e21..31dc2ebbc 100644 --- a/src/Dodge/LevelGen/MoveDoor.hs +++ b/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) diff --git a/src/Dodge/LevelGen/Pathing.hs b/src/Dodge/LevelGen/Pathing.hs index 5678c65b9..fd094d06b 100644 --- a/src/Dodge/LevelGen/Pathing.hs +++ b/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 diff --git a/src/Dodge/Lock.hs b/src/Dodge/Lock.hs deleted file mode 100644 index 31a97c00c..000000000 --- a/src/Dodge/Lock.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Dodge.Lock - where diff --git a/src/Dodge/Lock/Data.hs b/src/Dodge/Lock/Data.hs deleted file mode 100644 index 03c266037..000000000 --- a/src/Dodge/Lock/Data.hs +++ /dev/null @@ -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 diff --git a/src/Dodge/Room/CheckConsistency.hs b/src/Dodge/Room/CheckConsistency.hs index 2d1a5b32b..1d1127fcd 100644 --- a/src/Dodge/Room/CheckConsistency.hs +++ b/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 diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index 2c5d70701..e60b0001c 100644 --- a/src/Dodge/Room/Data.hs +++ b/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; diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 10e3b541f..934e2fe88 100644 --- a/src/Dodge/Room/Link.hs +++ b/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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index ded06e28d..c8058a33d 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/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 diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index ec65ba2cb..83b25f9d8 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/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 diff --git a/src/Dodge/Room/Treasure.hs b/src/Dodge/Room/Treasure.hs index cbd926af9..9552e8ebd 100644 --- a/src/Dodge/Room/Treasure.hs +++ b/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 diff --git a/src/Sound.hs b/src/Sound.hs index 8f00e8554..7e0812f5f 100644 --- a/src/Sound.hs +++ b/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') - * other fields are set to the new value. + * if the old sound is not fading and the chunk is the same, '_soundStatus' is set to the old 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 - | _soundStatus oldS == FadingOut - = newS & soundChannel .~ _soundChannel oldS - | _soundChunkID newS == _soundChunkID oldS +mergeSound oldS newS + | _soundChunkID newS == _soundChunkID oldS && _soundStatus oldS /= FadingOut = 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 diff --git a/test/Spec.hs b/test/Spec.hs index 4b0bb4237..903d23fcc 100644 --- a/test/Spec.hs +++ b/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)