From be7b2d2cd7467bda872356e94977c35e3cd28a48 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 9 Sep 2021 13:29:09 +0100 Subject: [PATCH] Add frame clock --- appDodge/Main.hs | 5 +-- src/Dodge/Clock.hs | 14 ++++++++ src/Dodge/Config/Update.hs | 20 +++++++---- src/Dodge/Creature/Action.hs | 17 ++++++++-- src/Dodge/Creature/ArmourChase.hs | 2 +- src/Dodge/Creature/Boid.hs | 6 ++-- src/Dodge/Creature/ChaseCrit.hs | 1 + src/Dodge/Creature/Impulse.hs | 4 +-- src/Dodge/Creature/Intention.hs | 2 ++ src/Dodge/Creature/Memory/Data.hs | 2 +- src/Dodge/Creature/Perception.hs | 4 +-- src/Dodge/Creature/Perception/Data.hs | 2 +- src/Dodge/Creature/Picture.hs | 44 +++++++++++++++--------- src/Dodge/Creature/ReaderUpdate.hs | 48 ++++++++++++++++++++------- src/Dodge/Creature/SentinelAI.hs | 2 +- src/Dodge/Creature/SetTarget.hs | 4 +-- src/Dodge/Creature/Test.hs | 12 +++---- src/Dodge/Data.hs | 19 ++++++++--- src/Dodge/Default.hs | 9 +++-- src/Dodge/Default/World.hs | 4 +-- src/Dodge/Event.hs | 6 +++- src/Dodge/Initialisation.hs | 6 ++-- src/Dodge/Menu.hs | 14 +++++--- src/Dodge/Room/Path.hs | 4 +-- src/Dodge/Update.hs | 6 +--- src/Sound/Data.hs | 4 +-- src/Tile.hs | 2 +- 27 files changed, 176 insertions(+), 87 deletions(-) create mode 100644 src/Dodge/Clock.hs create mode 100644 src/Dodge/Creature/Intention.hs diff --git a/appDodge/Main.hs b/appDodge/Main.hs index d269f9846..57372089f 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -63,6 +63,7 @@ doSideEffects w = do void $ doDrawing (_renderData preData) w playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w) newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_sounds w) + w' <- _sideEffects w w endTicks <- SDL.ticks let lastFrameTicks = _frameTimer preData @@ -73,9 +74,9 @@ doSideEffects w = do . translate (-0.5) (-0.8) . scale 0.0005 0.0005 . text $ "ms/frame " ++ show (endTicks - lastFrameTicks) ) - newpdata <- foldr (=<<) (return (preData & frameTimer .~ endTicks)) (_doneSideEffects w) - return $ w & preloadData .~ newpdata + return $ w' & preloadData . frameTimer .~ endTicks & playingSounds .~ newPlayingSounds + & sideEffects .~ return doPreload :: IO PreloadData doPreload = do diff --git a/src/Dodge/Clock.hs b/src/Dodge/Clock.hs new file mode 100644 index 000000000..8b0587aa1 --- /dev/null +++ b/src/Dodge/Clock.hs @@ -0,0 +1,14 @@ +module Dodge.Clock + ( clockCycle + ) + where +import Dodge.Data + +import qualified Data.Vector as V +clockCycle :: Int -> V.Vector a -> World -> a +{-# INLINABLE clockCycle #-} +clockCycle tPeriod xs w = xs V.! i + where + l = V.length xs + t = _frameClock w `mod` (l * tPeriod) + i = t `div` tPeriod diff --git a/src/Dodge/Config/Update.hs b/src/Dodge/Config/Update.hs index 998b3ad32..42d696026 100644 --- a/src/Dodge/Config/Update.hs +++ b/src/Dodge/Config/Update.hs @@ -14,20 +14,25 @@ import Data.Aeson (encodeFile) {- | Write the current world configuration to disk as a json file. -} -saveConfig :: Configuration -> PreloadData -> IO PreloadData -saveConfig cfig d = do +saveConfig :: Configuration -> (a -> IO a) -> a -> IO a +saveConfig cfig f x = do putStrLn "Saving config to data/dodge.config.json" encodeFile "data/dodge.config.json" cfig - return d + f x {- | Apply the volume settings from the world configuration to the running game. -} -setVol :: Configuration -> PreloadData -> IO PreloadData -setVol cfig d = do +setVol :: Configuration -> IO () +setVol cfig = do setSoundVolume ( _volume_master cfig * _volume_sound cfig) setMusicVolume ( _volume_master cfig * _volume_music cfig) - return d + +setVol' :: Configuration -> (a -> IO a) -> a -> IO a +setVol' cfig f a = do + setVol cfig + f a + {- | Apply /all/ of the values in the world configuration to the running game. @@ -37,7 +42,8 @@ applyWorldConfig -> PreloadData -> IO PreloadData applyWorldConfig cfig pdata = do - setVol cfig pdata >>= pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y + setVol cfig + pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y pdata where x = round $ _windowX cfig y = round $ _windowY cfig diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 43126415d..6ecdeb5aa 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -69,6 +69,16 @@ performPathTo cr w p cpos = _crPos cr jit = _mvTurnJit $ _crMvType cr +performTurnToA :: Creature -> Point2 -> OutAction +performTurnToA cr p + | angleVV cdirv dirv < 0.1 = ([], Nothing) + | otherwise = ([MvTurnToward p,RandomTurn jit] , Just (TurnToA p)) + where + cpos = _crPos cr + cdirv = unitVectorAtAngle (_crDir cr) + dirv = p -.- cpos + jit = _mvTurnJit $ _crMvType cr + {- | Performing an action means that a creature has some impulses for a frame, and updates or deletes the action itself. -- doAction -} @@ -108,13 +118,14 @@ performAction cr w ac = case ac of in (concat imps, Just . DoActions $ catMaybes newAcs) StartSentinelPost -> ([AddGoal $ SentinelAt (_crPos cr) (_crDir cr)], Nothing) PathTo p -> performPathTo cr w p - LeadTarget p -> case cr ^? crTarget . _Just of + TurnToA p -> performTurnToA cr p + LeadTarget p -> case cr ^? crIntention . targetCr . _Just of Just tcr -> ([TurnTo (_crPos tcr +.+ rotateV (_crDir tcr) p)], Nothing) _ -> ([], Nothing) - UseTarget f -> performAction cr w $ f $ cr ^? crTarget . _Just + UseTarget f -> performAction cr w $ f $ cr ^? crIntention . targetCr . _Just UseSelf f -> performAction cr w $ f cr UseAheadPos f -> performAction cr w (f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr))) - UseMvTargetPos f -> performAction cr w $ f $ _crMvTarget cr + UseMvTargetPos f -> performAction cr w $ f $ _mvToPoint $ _crIntention cr ArbitraryAction f -> performAction cr w (f cr w) DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of (imp, Just nxtac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp nxtac) diff --git a/src/Dodge/Creature/ArmourChase.hs b/src/Dodge/Creature/ArmourChase.hs index 089a8afc8..946ad946b 100644 --- a/src/Dodge/Creature/ArmourChase.hs +++ b/src/Dodge/Creature/ArmourChase.hs @@ -26,7 +26,7 @@ armourChaseCrit = defaultCreature doStrategyActionsR >=> performActionsR >=> targetYouWhenCognizantR >=> - setTargetMv (pure . _crTarget) >=> -- should be able to remove this? + setTargetMv (pure . _targetCr . _crIntention) >=> -- should be able to remove this? flockACCR >=> perceptionUpdate [0] >=> goToTarget >=> diff --git a/src/Dodge/Creature/Boid.hs b/src/Dodge/Creature/Boid.hs index 77a901550..e809d0a3e 100644 --- a/src/Dodge/Creature/Boid.hs +++ b/src/Dodge/Creature/Boid.hs @@ -171,7 +171,7 @@ swarmUsingCenter -> World -> Creature -> Creature -swarmUsingCenter updT upd w cr = case _crTarget cr of +swarmUsingCenter updT upd w cr = case _targetCr $ _crIntention cr of Nothing -> upd cenp cr Just tcr -> updT tcr cenp cr where @@ -184,7 +184,7 @@ flockChaseTarget -> World -> Creature -> Creature -flockChaseTarget updT upd w cr = case _crTarget cr of +flockChaseTarget updT upd w cr = case _targetCr $ _crIntention cr of Nothing -> upd crs cr Just tcr -> updT tcr crs cr where @@ -210,7 +210,7 @@ flockToPointUsing -> (Point2 -> Creature -> Creature -> [Impulse]) -> Creature -> Reader World Creature -flockToPointUsing pf mvf cr = reader $ \w -> case _crTarget cr of +flockToPointUsing pf mvf cr = reader $ \w -> case _targetCr $ _crIntention cr of Nothing -> cr Just tcr -> cr & crActionPlan . crImpulse .~ mvf ptarg cr tcr where diff --git a/src/Dodge/Creature/ChaseCrit.hs b/src/Dodge/Creature/ChaseCrit.hs index d82223b3b..78d28c615 100644 --- a/src/Dodge/Creature/ChaseCrit.hs +++ b/src/Dodge/Creature/ChaseCrit.hs @@ -38,6 +38,7 @@ chaseCrit = defaultCreature doStrategyActionsR >=> performActionsR >=> overrideMeleeCloseTargetR >=> + setViewPos >=> setMvPos >=> -- setTargetMv (pure . _crTarget) >=> goToTarget >=> diff --git a/src/Dodge/Creature/Impulse.hs b/src/Dodge/Creature/Impulse.hs index b69dfe346..86846ce30 100644 --- a/src/Dodge/Creature/Impulse.hs +++ b/src/Dodge/Creature/Impulse.hs @@ -62,10 +62,10 @@ followImpulse cr w imp = case imp of AddGoal gl -> (id, cr & crActionPlan . crGoal %~ (gl :) ) ArbitraryImpulseFunction f -> (id, f w cr) ArbitraryImpulse f -> followImpulse cr w (f cr w) - ImpulseUseTargetCID f -> case cr ^? crTarget . _Just of + ImpulseUseTargetCID f -> case cr ^? crIntention . targetCr . _Just of Just tcr -> followImpulse cr w (f $ _crID tcr) _ -> (id,cr) - ImpulseUseTarget f -> case cr ^? crTarget . _Just of + ImpulseUseTarget f -> case cr ^? crIntention . targetCr . _Just of Just tcr -> followImpulse cr w (f tcr) _ -> (id,cr) ImpulseUseAheadPos f -> followImpulse cr w (f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr))) diff --git a/src/Dodge/Creature/Intention.hs b/src/Dodge/Creature/Intention.hs new file mode 100644 index 000000000..247b306f9 --- /dev/null +++ b/src/Dodge/Creature/Intention.hs @@ -0,0 +1,2 @@ +module Dodge.Creature.Intention + where diff --git a/src/Dodge/Creature/Memory/Data.hs b/src/Dodge/Creature/Memory/Data.hs index 5416a5e08..71f255098 100644 --- a/src/Dodge/Creature/Memory/Data.hs +++ b/src/Dodge/Creature/Memory/Data.hs @@ -6,7 +6,7 @@ import Geometry.Data import Control.Lens -data MemoryState = MemoryState +newtype MemoryState = MemoryState { _soundsToInvestigate :: [Point2] } diff --git a/src/Dodge/Creature/Perception.hs b/src/Dodge/Creature/Perception.hs index f956fd173..674a1684f 100644 --- a/src/Dodge/Creature/Perception.hs +++ b/src/Dodge/Creature/Perception.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} module Dodge.Creature.Perception ( perceptionUpdate , newSounds @@ -96,7 +96,7 @@ newSounds = mapMaybe f . M.elems . _playingSounds rememberSounds :: Creature -> Reader World Creature rememberSounds cr = do - sList <- fmap newSounds ask + sList <- asks newSounds return $ cr & crMemory . soundsToInvestigate .~ map fst (filter (soundIsClose cr) sList) -- return $ cr & crMemory . soundsToInvestigate .~ [V2 0 0] diff --git a/src/Dodge/Creature/Perception/Data.hs b/src/Dodge/Creature/Perception/Data.hs index 9e2252466..6f4d2ac12 100644 --- a/src/Dodge/Creature/Perception/Data.hs +++ b/src/Dodge/Creature/Perception/Data.hs @@ -35,7 +35,7 @@ data Vision = Eyes { _viFOV :: Float -> Float , _viDist :: Float -> Float } -data Audition = Ears +newtype Audition = Ears { _auDist :: Float -> Float } diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index eb43fe6b2..11ef124c1 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -10,14 +10,15 @@ module Dodge.Creature.Picture import Dodge.Data --import Dodge.Base --import Dodge.Creature.Stance.Data ---import Dodge.Creature.Perception.Data +import Dodge.Creature.Perception.Data import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data -import Dodge.Creature.Memory.Data +--import Dodge.Creature.Memory.Data import Dodge.Creature.Test --import Dodge.Creature.AlertLevel.Data --import Dodge.Picture.Layer import Dodge.Item.Data +import Dodge.Clock import Picture import Geometry --import Geometry.Vector3D @@ -25,6 +26,7 @@ import Geometry import Control.Lens import Data.List import qualified Data.IntMap.Strict as IM +import qualified Data.Vector as V basicCrPict :: Color -- ^ Creature color -> Creature @@ -56,26 +58,38 @@ creatureDisplayText w cr . color white . rotate a . scale theScale theScale - $ text $ creatureDisplayString cr + . text + $ clockCycle 50 (V.fromList [crDisplayAwake, crDisplayAlert]) w cr where campos = _cameraViewFrom w - theScale = 0.2 / _cameraZoom w + theScale = 0.15 / _cameraZoom w cpos = _crPos cr v = cpos -.- campos a = argV v - 0.5 * pi (V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v -creatureDisplayString :: Creature -> String -creatureDisplayString cr = show . take 1 . _soundsToInvestigate $ _crMemory cr --- | isAsleep = "Z" --- | isSuspicious = "?" --- | otherwise = "" --- where --- isAsleep = _crAwakeLevel (_crPerception cr) == Asleep --- imAwarenesses = _crAwarenessLevel (_crPerception cr) --- isSuspicious = any f imAwarenesses && not (null imAwarenesses) --- f (Suspicious _) = True --- f _ = False + +crDisplayAlert :: Creature -> String +crDisplayAlert cr + | isSuspicious = "?" + | isCognizant = "!" + | otherwise = "." + where + imAwarenesses = _crAwarenessLevel (_crPerception cr) + isSuspicious = any f imAwarenesses && not (null imAwarenesses) + isCognizant = any g imAwarenesses && not (null imAwarenesses) + f (Suspicious _) = True + f _ = False + g (Cognizant _) = True + g _ = False + +crDisplayAwake :: Creature -> String +crDisplayAwake cr = case _crAwakeLevel (_crPerception cr) of + Comatose -> "-" + Asleep -> "Z" + Lethargic -> "L" + Vigilant -> "V" + Overstrung -> "O" damageMod :: Creature -> Picture -> Picture damageMod cr pic = piercingMod $ bluntScale pic where diff --git a/src/Dodge/Creature/ReaderUpdate.hs b/src/Dodge/Creature/ReaderUpdate.hs index 18004d88b..ec18039b0 100644 --- a/src/Dodge/Creature/ReaderUpdate.hs +++ b/src/Dodge/Creature/ReaderUpdate.hs @@ -10,6 +10,7 @@ module Dodge.Creature.ReaderUpdate , goToTarget , flockACCR , setMvPos + , setViewPos ) where import Dodge.Data @@ -19,6 +20,7 @@ import Dodge.Creature.Test import Dodge.Creature.Volition import Dodge.Creature.Perception.Data import Dodge.Base +import Dodge.Base.Collide import Geometry import FoldableHelp @@ -31,7 +33,7 @@ import Data.Maybe overrideMeleeCloseTargetR :: Creature -> Reader World Creature -overrideMeleeCloseTargetR cr = return $ maybe cr (tryMeleeAttack cr) (_crTarget cr) +overrideMeleeCloseTargetR cr = return $ maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr) tryMeleeAttack :: Creature -> Creature -> Creature tryMeleeAttack cr tcr @@ -45,11 +47,17 @@ tryMeleeAttack cr tcr cpos = _crPos cr setMvPos :: Creature -> Reader World Creature -setMvPos cr = pure $ cr & crMvTarget .~ mpos +setMvPos cr = pure $ cr & crIntention . mvToPoint .~ mpos where - mpos = (_crPos <$> _crTarget cr) - <|> _crMvTarget cr - <|> listToMaybe (_soundsToInvestigate $ _crMemory cr) + int = _crIntention cr + mpos = (_crPos <$> _targetCr int) + <|> _mvToPoint int +-- <|> listToMaybe (_soundsToInvestigate $ _crMemory cr) + +setViewPos :: Creature -> Reader World Creature +setViewPos cr = pure $ cr & crIntention . viewPoint %~ (<|> mpos) + where + mpos = listToMaybe (_soundsToInvestigate $ _crMemory cr) setTargetMv :: (Creature -> Reader World (Maybe Creature)) -- ^ Function for determining target @@ -59,10 +67,10 @@ setTargetMv targFunc cr = do targ <- targFunc cr case targ of Nothing -> pure cr - Just crTarg -> pure $ cr & crMvTarget .~ Just (_crPos crTarg) + Just crTarg -> pure $ cr & crIntention . mvToPoint ?~ _crPos crTarg flockACCR :: Creature -> Reader World Creature flockACCR cr = do - case cr ^? crTarget . _Just of + case cr ^? crIntention . targetCr . _Just of Nothing -> pure cr Just tcr -> do w <- ask @@ -81,13 +89,29 @@ flockACCR cr = do horShift = if isLHS tpos cpos (_crPos acr) then r *.* horDir else negate r *.* horDir - pure $ cr & crMvTarget .~ Just (tpos +.+ horShift) + pure $ cr & crIntention . mvToPoint ?~ tpos +.+ horShift goToTarget :: Creature -> Reader World Creature goToTarget cr = do - case cr ^? crMvTarget . _Just of + case cr ^? crIntention . mvToPoint . _Just of Just p -> pure $ cr & crActionPlan . crAction .~ [PathTo p] - _ -> pure cr + _ -> viewTarget cr + +viewTarget :: Creature -> Reader World Creature +viewTarget cr = do + w <- ask + case cr ^? crIntention . viewPoint . _Just of + Just p | hasLOSIndirect p (_crPos cr) w -> pure $ cr' + & crActionPlan . crAction %~ replaceNullWith (TurnToA p) + & crIntention . viewPoint .~ Nothing + | otherwise -> pure $ cr' & crActionPlan . crAction %~ replaceNullWith (PathTo p) + Nothing -> pure $ cr & crPerception . crAwakeLevel .~ Lethargic + where + cr' = cr & crPerception . crAwakeLevel .~ Vigilant + +replaceNullWith :: a -> [a] -> [a] +replaceNullWith x [] = [x] +replaceNullWith _ xs = xs doStrategyActionsR :: Creature @@ -138,5 +162,5 @@ listGuard (_,z) _ = z targetYouWhenCognizantR :: Creature -> Reader World Creature targetYouWhenCognizantR cr = reader $ \w -> case cr ^? crPerception . crAwarenessLevel . ix 0 of - Just (Cognizant _) -> cr {_crTarget = Just $! _creatures w IM.! 0} - _ -> cr & crTarget .~ Nothing + Just (Cognizant _) -> cr & crIntention . targetCr ?~ _creatures w IM.! 0 + _ -> cr & crIntention . targetCr .~ Nothing diff --git a/src/Dodge/Creature/SentinelAI.hs b/src/Dodge/Creature/SentinelAI.hs index ad9e4cff8..50007d1b3 100644 --- a/src/Dodge/Creature/SentinelAI.hs +++ b/src/Dodge/Creature/SentinelAI.hs @@ -40,7 +40,7 @@ sentinelAI = sentinelExtraWatchUpdate >=> reloadOverrideR where advanceShoot = DoImpulses [UseItem, MoveForward 3] - tcid cr = _crID <$> _crTarget cr + tcid cr = _crID <$> _targetCr (_crIntention cr) lostest (w,cr) = maybe False (\cid -> canSee (_crID cr) cid w) (tcid cr) sentinelFireType diff --git a/src/Dodge/Creature/SetTarget.hs b/src/Dodge/Creature/SetTarget.hs index e81afbc88..7d290980f 100644 --- a/src/Dodge/Creature/SetTarget.hs +++ b/src/Dodge/Creature/SetTarget.hs @@ -14,6 +14,6 @@ targetYouWhenCognizant -> Creature -> Creature targetYouWhenCognizant w cr = case cr ^? crPerception . crAwarenessLevel . ix 0 of - Just (Cognizant _) -> cr & crTarget ?~ _creatures w IM.! 0 - _ -> cr & crTarget .~ Nothing + Just (Cognizant _) -> cr & crIntention . targetCr ?~ _creatures w IM.! 0 + _ -> cr & crIntention . targetCr .~ Nothing diff --git a/src/Dodge/Creature/Test.hs b/src/Dodge/Creature/Test.hs index aaa57e0ec..7d0eccf18 100644 --- a/src/Dodge/Creature/Test.hs +++ b/src/Dodge/Creature/Test.hs @@ -56,28 +56,28 @@ crIsAimingR :: Creature -> Reader World Bool crIsAimingR cr = return $ _posture (_crStance cr) == Aiming crHasTarget :: (World,Creature) -> Bool -crHasTarget (_,cr) = isJust $ cr ^? crTarget . _Just +crHasTarget (_,cr) = isJust $ cr ^? crIntention . targetCr . _Just crHasTargetR :: Creature -> Reader World Bool -crHasTargetR cr = return $ isJust $ cr ^? crTarget . _Just +crHasTargetR cr = return $ isJust $ cr ^? crIntention . targetCr . _Just crHasTargetLOS :: (World,Creature) -> Bool -crHasTargetLOS (w,cr) = case cr ^? crTarget . _Just of +crHasTargetLOS (w,cr) = case cr ^? crIntention . targetCr . _Just of Just i -> crCanSeeCr i (w,cr) Nothing -> False crHasTargetLOSR :: Creature -> Reader World Bool -crHasTargetLOSR cr = reader $ \w -> case cr ^? crTarget . _Just of +crHasTargetLOSR cr = reader $ \w -> case cr ^? crIntention . targetCr . _Just of Just i -> crCanSeeCr i (w,cr) Nothing -> False crSafeDistFromTarg :: Float -> (World,Creature) -> Bool -crSafeDistFromTarg d (_,cr) = case cr ^? crTarget . _Just of +crSafeDistFromTarg d (_,cr) = case cr ^? crIntention . targetCr . _Just of Just tcr -> dist (_crPos cr) (_crPos tcr) > d Nothing -> True crSafeDistFromTargR :: Float -> Creature -> Reader World Bool -crSafeDistFromTargR d cr = return $ case cr ^? crTarget . _Just of +crSafeDistFromTargR d cr = return $ case cr ^? crIntention . targetCr . _Just of Just tcr -> dist (_crPos cr) (_crPos tcr) > d Nothing -> True diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 181a0e99f..9d4ff1575 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -103,14 +103,14 @@ data World = World , _selLocation :: Int , _keyConfig :: KeyConfigSDL , _config :: Configuration - , _sideEffects :: [PreloadData -> IO PreloadData] - , _doneSideEffects :: [PreloadData -> IO PreloadData] + , _sideEffects :: World -> IO World , _debugFlags :: DebugFlags , _inventoryMode :: InventoryMode , _lClickHammer :: HammerPosition , _radDistortion :: [(Point2,Point2,Point2,Float)] , _gameRooms :: [GameRoom] , _preloadData :: PreloadData + , _frameClock :: Int } data OptionScreenFlag = NormalOptions | GameOverOptions data ScreenLayer @@ -221,10 +221,15 @@ data Creature = Creature , _crMemory :: MemoryState , _crFaction :: Faction , _crGroup :: CrGroup - , _crTarget :: Maybe Creature - , _crMvTarget :: Maybe Point2 + , _crIntention :: Intention , _crMvType :: CrMvType } +data Intention = Intention + { _targetCr :: Maybe Creature + , _mvToPoint :: Maybe Point2 + , _viewPoint :: Maybe Point2 + } + data CrMvType = NoMvType | ChaseMvType @@ -580,7 +585,7 @@ data Impulse | DropItem -- | PickupNearby Int -- | UseWorldObject Int - | Bark -- placeholder for various communication types +-- | Bark -- placeholder for various communication types -- | UseIntrinsicAbility | Melee Int | ChangePosture Posture @@ -612,6 +617,9 @@ data Action | PathTo {_pathToPoint :: Point2 } + | TurnToA + {_turnToAPoint :: Point2 + } -- | PickupItem -- {_pickupItemID :: Int -- } @@ -737,6 +745,7 @@ makeLenses ''Impulse makeLenses ''Action makeLenses ''CrGroupParams makeLenses ''CrMvType +makeLenses ''Intention numColor :: Int -> Color numColor 0 = toV4 (1,0,0,1) numColor 1 = toV4 (0,1,0,1) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 1ce58ebd5..c26ff20d4 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -54,8 +54,7 @@ defaultCreature = Creature , _crMemory = defaultCreatureMemory , _crMeleeCooldown = 0 , _crFaction = NoFaction - , _crTarget = Nothing - , _crMvTarget= Nothing + , _crIntention = defaultIntention , _crGroup = LoneWolf , _crMvType = defaultAimMvType } @@ -86,6 +85,12 @@ defaultAudition :: Audition defaultAudition = Ears { _auDist = \x -> x * x } +defaultIntention :: Intention +defaultIntention = Intention + { _targetCr = Nothing + , _mvToPoint = Nothing + , _viewPoint = Nothing + } defaultChaseMvType :: CrMvType defaultChaseMvType = ChaseMvType { _mvSpeed = 3 diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 87515030b..804e6a5c8 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -76,8 +76,7 @@ defaultWorld = World , _selLocation = 0 , _keyConfig = defaultKeyConfigSDL , _config = defaultConfig - , _sideEffects = [] - , _doneSideEffects = [] + , _sideEffects = return , _debugFlags = defaultDebugFlags , _inventoryMode = TopInventory , _lClickHammer = HammerUp @@ -86,6 +85,7 @@ defaultWorld = World , _radDistortion = [] , _gameRooms = [] , _preloadData = DummyPdata -- hack TODO remove this + , _frameClock = 0 } defaultDebugFlags :: DebugFlags defaultDebugFlags = DebugFlags diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 126a5a70f..57db98ec6 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -65,9 +65,13 @@ handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World handleResizeEvent sev w = Just . set (config . windowX) (fromIntegral x) . set (config . windowY) (fromIntegral y) - $ over sideEffects (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : ) + $ over sideEffects up w where + up :: (World -> IO World) -> World -> IO World + up f w' = do + pdata <- pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y (_preloadData w') + f $ w' & preloadData .~ pdata x = fromIntegral x' y = fromIntegral y' V2 x' y' = windowSizeChangedEventSize sev diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index a91a0d3a8..e8947446a 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -9,7 +9,7 @@ import Dodge.Story import Dodge.WorldEvent.Cloud import Dodge.SoundLogic import Dodge.SoundLogic.Synonyms -import Dodge.Creature.Perception +--import Dodge.Creature.Perception import Geometry.Data --import Dodge.GameRoom --import Geometry @@ -53,8 +53,8 @@ initialWorld = defaultWorld , _worldState = M.empty } testStringInit :: World -> [String] ---testStringInit _ = [] -testStringInit w = [show . length $ newSounds w] +testStringInit _ = [] +--testStringInit w = [show . length $ newSounds w] --testStringInit w = (show . _crPos $ _creatures w IM.! 0) -- : (map show . _grBound . last $ sortOn _grName grs) -- ++ closeRooms diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 72a067881..7a7812fc8 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -53,7 +53,8 @@ soundMenuOptions = where dec x = max 0 (x - 0.1) inc x = min 1 (x + 0.1) - sw w = w & sideEffects %~ (setVol (_config w) : ) + --sw w = w & sideEffects %~ (setVol (_config w) : ) + sw w = w & sideEffects %~ setVol' (_config w) master g = Just . (config . volume_master %~ g) soundEffs g = Just . (config . volume_sound %~ g) music g = Just . (config . volume_music %~ g) @@ -70,7 +71,7 @@ popScreen :: World -> Maybe World popScreen = Just . (menuLayers %~ tail) writeConfig :: World -> World -writeConfig w = w & sideEffects %~ (saveConfig (_config w) :) +writeConfig w = w & sideEffects %~ saveConfig (_config w) graphicsMenu :: ScreenLayer graphicsMenu = OptionScreen @@ -138,12 +139,15 @@ charToScode :: Char -> Scancode charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum updateFramebufferSize :: World -> World -updateFramebufferSize w = w & sideEffects - %~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : ) +updateFramebufferSize w = w & sideEffects %~ up where (x,y) = (round $ getWindowX w, round $ getWindowY w) divRes = w ^. config . resolution_factor - + up :: (World -> IO World) -> World -> IO World + up f w' = do + pdata <- pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y (_preloadData w') + f $ w' & preloadData .~ pdata + levelMenu :: Int -> ScreenLayer levelMenu x = OptionScreen { _scTitle = const $ "LEVEL "++ show x diff --git a/src/Dodge/Room/Path.hs b/src/Dodge/Room/Path.hs index 954038cc8..48b3d7b83 100644 --- a/src/Dodge/Room/Path.hs +++ b/src/Dodge/Room/Path.hs @@ -22,9 +22,7 @@ createPathGrid rm = rm { _rmPath = linksAndPath (_rmLinks rm) filterGrid } where filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid - grid = case shiftedGrid <$> minx <*> maxx <*> miny <*> maxy of - Nothing -> [] - Just xs -> xs + grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy outerWalls = foldr cutPoly [] $ _rmPolys rm outerPoints = map fst outerWalls (minx, maxx, miny, maxy) = L.fold theFold outerPoints diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 3f869db23..b2db155c4 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -35,12 +35,8 @@ import System.Random --import Data.Bifunctor update :: World -> World -update = functionalUpdate . pushSideEffects +update = (frameClock +~ 1) . functionalUpdate -pushSideEffects :: World -> World -pushSideEffects w = w - & sideEffects .~ [] - & doneSideEffects .~ _sideEffects w {- | The update step. For most menus the only way to change the world is using event handling. -} diff --git a/src/Sound/Data.hs b/src/Sound/Data.hs index 9fc1e28c5..d515344d6 100644 --- a/src/Sound/Data.hs +++ b/src/Sound/Data.hs @@ -3,7 +3,7 @@ module Sound.Data where import qualified SDL.Mixer as Mix import qualified Data.IntMap.Strict as IM -import qualified Data.Map.Strict as M +--import qualified Data.Map.Strict as M import Control.Lens import Geometry.Data import Data.Word (Word8) @@ -16,7 +16,7 @@ data SoundStatus | ToStart deriving (Eq,Ord,Show) -data SoundData = SoundData +newtype SoundData = SoundData {_loadedChunks :: IM.IntMap Mix.Chunk } data Sound = Sound diff --git a/src/Tile.hs b/src/Tile.hs index d8af055af..c565a0b23 100644 --- a/src/Tile.hs +++ b/src/Tile.hs @@ -36,7 +36,7 @@ makeTileFromPoly poly z = Tile { _tilePoly = poly , _tileZero = c --, _tileXY = c +.+ xdir +.+ vNormal xdir - , _tileX = c +.+ (normalizeV $ (poly !! 1) -.- c) + , _tileX = c +.+ normalizeV ((poly !! 1) -.- c) , _tileZ = z } where