From 8a4220df830adb6f1616ca02dd06902474fd25df Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 13 Oct 2019 12:37:08 -0400 Subject: Implement speed and ticks Gormlaks now move 1/8th the speed of the character, which means we can run away from them - yay! Unfortunately this also introduces a bug where they'll eventually get stuck and not do anything, so I'll be tackling that next. --- src/Xanthous/AI/Gormlak.hs | 72 +++++++++++------ src/Xanthous/App.hs | 25 ++++-- src/Xanthous/Data.hs | 137 ++++++++++++++++++++++++++------ src/Xanthous/Entities/Character.hs | 10 +++ src/Xanthous/Entities/Creature.hs | 69 ++++++++++++++-- src/Xanthous/Entities/RawTypes.hs | 19 +++-- src/Xanthous/Entities/Raws/gormlak.yaml | 2 +- src/Xanthous/Game/Draw.hs | 2 +- src/Xanthous/Game/State.hs | 15 ++-- src/Xanthous/Generators.hs | 2 +- 10 files changed, 273 insertions(+), 80 deletions(-) (limited to 'src/Xanthous') diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs index db504c1e7d3a..e13eb8ffe71a 100644 --- a/src/Xanthous/AI/Gormlak.hs +++ b/src/Xanthous/AI/Gormlak.hs @@ -10,10 +10,17 @@ import Control.Monad.Random import Data.Aeson (object) import qualified Data.Aeson as A -------------------------------------------------------------------------------- -import Xanthous.Data (Positioned(..), diffPositions, stepTowards, isUnit) +import Xanthous.Data + ( Positioned(..), positioned, position + , diffPositions, stepTowards, isUnit + , Ticks, (|*|), invertedRate + ) import Xanthous.Data.EntityMap import qualified Xanthous.Entities.Creature as Creature -import Xanthous.Entities.Creature (Creature) +import Xanthous.Entities.Creature + ( Creature, hippocampus, creatureType + , destination, destinationProgress, destinationPosition + ) import Xanthous.Entities.Character (Character) import qualified Xanthous.Entities.Character as Character import qualified Xanthous.Entities.RawTypes as Raw @@ -28,30 +35,47 @@ import Xanthous.Monad (say) stepGormlak :: (MonadState GameState m, MonadRandom m) - => Positioned Creature + => Ticks + -> Positioned Creature -> m (Positioned Creature) -stepGormlak pe@(Positioned pos creature) = do - newPos <- do - canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision - if canSeeCharacter - then do - charPos <- use characterPosition - if isUnit (pos `diffPositions` charPos) - then attackCharacter $> pos - else pure $ pos `stepTowards` charPos +stepGormlak ticks pe@(Positioned pos creature) = do + dest <- maybe (selectDestination pos creature) pure + $ creature ^. hippocampus . destination + let progress' = + dest ^. destinationProgress + + creature ^. creatureType . Raw.speed . invertedRate |*| ticks + if progress' < 1 + then pure + $ pe + & positioned . hippocampus . destination + ?~ (dest & destinationProgress .~ progress') else do - lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature) - line <- choose $ weightedBy length lines - pure $ fromMaybe pos $ fmap fst . headMay =<< tailMay =<< line - collisionAt newPos >>= \case - Nothing -> pure $ Positioned newPos creature - Just Stop -> pure pe - Just Combat -> do - ents <- use $ entities . atPosition newPos - when (any (entityIs @Character) ents) attackCharacter - pure pe - + let newPos = dest ^. destinationPosition + remainingSpeed = progress' - 1 + newDest <- selectDestination newPos creature + <&> destinationProgress +~ remainingSpeed + let pe' = pe & positioned . hippocampus . destination ?~ newDest + collisionAt newPos >>= \case + Nothing -> pure $ pe' & position .~ newPos + Just Stop -> pure pe' + Just Combat -> do + ents <- use $ entities . atPosition newPos + when (any (entityIs @Character) ents) attackCharacter + pure pe' where + selectDestination pos' creature' = Creature.destinationFromPos <$> do + canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision + if canSeeCharacter + then do + charPos <- use characterPosition + if isUnit (pos' `diffPositions` charPos) + then attackCharacter $> pos' + else pure $ pos' `stepTowards` charPos + else do + lines <- uses entities $ linesOfSight pos' (Creature.visionRadius creature') + line <- choose $ weightedBy length lines + pure $ fromMaybe pos' $ fmap fst . headMay =<< tailMay =<< line + vision = Creature.visionRadius creature attackCharacter = do say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ] @@ -60,7 +84,7 @@ stepGormlak pe@(Positioned pos creature) = do newtype GormlakBrain = GormlakBrain Creature instance Brain GormlakBrain where - step = fmap coerce . stepGormlak . coerce + step ticks = fmap coerce . stepGormlak ticks . coerce -------------------------------------------------------------------------------- diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 7c103ccfbcb3..d3f266a1e340 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -22,6 +22,9 @@ import Xanthous.Data , Dimensions'(Dimensions) , positioned , Position + , Ticks + , Position'(Position) + , (|*|) ) import Xanthous.Data.EntityMap (EntityMap) import qualified Xanthous.Data.EntityMap as EntityMap @@ -85,11 +88,11 @@ initLevel = do -------------------------------------------------------------------------------- -stepGame :: AppM () -stepGame = do +stepGameBy :: Ticks -> AppM () +stepGameBy ticks = do ents <- uses entities EntityMap.toEIDsAndPositioned for_ ents $ \(eid, pEntity) -> do - pEntity' <- step pEntity + pEntity' <- step ticks pEntity entities . ix eid .= pEntity' whenM (uses (character . characterHitpoints) (== 0)) @@ -97,6 +100,12 @@ stepGame = do . const . lift . liftIO $ exitSuccess +ticksPerTurn :: Ticks +ticksPerTurn = 100 + +stepGame :: AppM () +stepGame = stepGameBy ticksPerTurn + -------------------------------------------------------------------------------- handleEvent :: BrickEvent Name () -> AppM (Next GameState) @@ -119,7 +128,7 @@ handleCommand (Move dir) = do collisionAt newPos >>= \case Nothing -> do characterPosition .= newPos - stepGame + stepGameBy =<< uses (character . speed) (|*| 1) describeEntitiesAt newPos modify updateCharacterVision Just Combat -> attackAt newPos @@ -135,7 +144,7 @@ handleCommand PickUp = do character %= Character.pickUpItem item entities . at itemID .= Nothing say ["items", "pickUp"] $ object [ "item" A..= item ] - stepGame + stepGameBy 100 -- TODO _ -> undefined continue @@ -155,7 +164,7 @@ handleCommand Open = do entities . ix eid . positioned . _SomeEntity . open .= True say_ ["open", "success"] pure () - stepGame + stepGame -- TODO continue handleCommand Wait = stepGame >> continue @@ -180,7 +189,7 @@ handleCommand Eat = do character . characterHitpoints += edibleItem ^. hitpointsHealed . to fromIntegral message msg $ object ["item" A..= item] - stepGame + stepGame -- TODO continue handleCommand ToggleRevealAll = do @@ -318,4 +327,4 @@ attackAt pos = else do say ["combat", "hit"] msgParams entities . ix creatureID . positioned .= SomeEntity creature' - stepGame + stepGame -- TODO diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index b7df191e58a8..569922843644 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoTypeSynonymInstances #-} -------------------------------------------------------------------------------- -- | Common data types for Xanthous -------------------------------------------------------------------------------- module Xanthous.Data ( -- * - Position(..) + Position'(..) + , Position , x , y @@ -26,6 +30,17 @@ module Xanthous.Data , stepTowards , isUnit + -- * + , Per(..) + , invertRate + , invertedRate + , (|*|) + , Ticks(..) + , Tiles(..) + , TicksPerTile + , TilesPerTick + , timesTiles + -- * , Dimensions'(..) , Dimensions @@ -51,33 +66,67 @@ import Test.QuickCheck (Arbitrary, CoArbitrary, Function) import Test.QuickCheck.Arbitrary.Generic import Data.Group import Brick (Location(Location), Edges(..)) +import Data.Monoid (Product(..), Sum(..)) +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Util (EqEqProp(..), EqProp) import Xanthous.Orphans () import Xanthous.Util.Graphics -------------------------------------------------------------------------------- -data Position where - Position :: { _x :: Int - , _y :: Int - } -> Position - deriving stock (Show, Eq, Generic, Ord) - deriving anyclass (Hashable, CoArbitrary, Function) - deriving EqProp via EqEqProp Position -makeLenses ''Position +-- fromScalar ∘ scalar ≡ id +class Scalar a where + scalar :: a -> Double + fromScalar :: Double -> a + +instance Scalar Double where + scalar = id + fromScalar = id + +newtype ScalarIntegral a = ScalarIntegral a + deriving newtype (Eq, Ord, Num, Enum, Real, Integral) +instance Integral a => Scalar (ScalarIntegral a) where + scalar = fromIntegral + fromScalar = floor + +deriving via (ScalarIntegral Integer) instance Scalar Integer +deriving via (ScalarIntegral Word) instance Scalar Word -instance Arbitrary Position where +-------------------------------------------------------------------------------- + +data Position' a where + Position :: { _x :: a + , _y :: a + } -> (Position' a) + deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable) + deriving anyclass (NFData, Hashable, CoArbitrary, Function) + deriving EqProp via EqEqProp (Position' a) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + (Position' a) +makeLenses ''Position' + +type Position = Position' Int + +instance Arbitrary a => Arbitrary (Position' a) where arbitrary = genericArbitrary shrink = genericShrink -instance Semigroup Position where +instance Num a => Semigroup (Position' a) where (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂) -instance Monoid Position where +instance Num a => Monoid (Position' a) where mempty = Position 0 0 -instance Group Position where - invert (Position px py) = Position (-px) (-py) +instance Num a => Group (Position' a) where + invert (Position px py) = Position (negate px) (negate py) + +-- | Positions convert to scalars by discarding their orientation and just +-- measuring the length from the origin +instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where + scalar = fromIntegral . length . line (0, 0) . view _Position + fromScalar n = Position (fromScalar n) (fromScalar n) data Positioned a where Positioned :: Position -> a -> Positioned a @@ -110,32 +159,32 @@ loc = iso hither yon hither (Position px py) = Location (px, py) yon (Location (lx, ly)) = Position lx ly -_Position :: Iso' Position (Int, Int) +_Position :: Iso' (Position' a) (a, a) _Position = iso hither yon where hither (Position px py) = (px, py) yon (lx, ly) = Position lx ly -positionFromPair :: (Integral i, Integral j) => (i, j) -> Position +positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) -- | Add two positions -- -- Operation for the additive group on positions -addPositions :: Position -> Position -> Position +addPositions :: Num a => Position' a -> Position' a -> Position' a addPositions = (<>) -- | Subtract two positions. -- -- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) -diffPositions :: Position -> Position -> Position +diffPositions :: Num a => Position' a -> Position' a -> Position' a diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂) -- | Is this position a unit position? or: When taken as a difference, does this -- position represent a step of one tile? -- -- ∀ dir :: Direction. isUnit ('asPosition' dir) -isUnit :: Position -> Bool +isUnit :: (Eq a, Num a) => Position' a -> Bool isUnit (Position px py) = abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0) @@ -291,3 +340,41 @@ neighborPositions :: Position -> Neighbors Position neighborPositions pos = (`move` pos) <$> neighborDirections -------------------------------------------------------------------------------- + +newtype Per a b = Rate Double + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Enum, Real, ToJSON, FromJSON) via Double + deriving (Semigroup, Monoid) via Product Double +instance Arbitrary (Per a b) where arbitrary = genericArbitrary + +invertRate :: a `Per` b -> b `Per` a +invertRate (Rate p) = Rate $ 1 / p + +invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b') +invertedRate = iso invertRate invertRate + +infixl 7 |*| +(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a +(|*|) (Rate rate) b = fromScalar $ rate * scalar b + +newtype Ticks = Ticks Word + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word + deriving (Semigroup, Monoid) via (Sum Word) + deriving Scalar via ScalarIntegral Ticks +instance Arbitrary Ticks where arbitrary = genericArbitrary + +newtype Tiles = Tiles Double + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double + deriving (Semigroup, Monoid) via (Sum Double) +instance Arbitrary Tiles where arbitrary = genericArbitrary + +type TicksPerTile = Ticks `Per` Tiles +type TilesPerTick = Tiles `Per` Ticks + +timesTiles :: TicksPerTile -> Tiles -> Ticks +timesTiles = (|*|) diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 84e653e6a09d..7d2d22c9983b 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -5,6 +5,9 @@ module Xanthous.Entities.Character , inventory , characterDamage , characterHitpoints + , speed + + -- * , mkCharacter , pickUpItem , isDead @@ -12,6 +15,7 @@ module Xanthous.Entities.Character ) where -------------------------------------------------------------------------------- import Xanthous.Prelude +-------------------------------------------------------------------------------- import Test.QuickCheck import Test.QuickCheck.Instances.Vector () import Test.QuickCheck.Arbitrary.Generic @@ -21,6 +25,7 @@ import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Entities import Xanthous.Entities.Item +import Xanthous.Data (TicksPerTile) -------------------------------------------------------------------------------- data Character = Character @@ -28,6 +33,7 @@ data Character = Character , _characterName :: !(Maybe Text) , _characterDamage :: !Word , _characterHitpoints :: !Word + , _speed :: TicksPerTile } deriving stock (Show, Eq, Generic) deriving anyclass (CoArbitrary, Function) @@ -58,12 +64,16 @@ instance Arbitrary Character where initialHitpoints :: Word initialHitpoints = 10 +defaultSpeed :: TicksPerTile +defaultSpeed = 100 + mkCharacter :: Character mkCharacter = Character { _inventory = mempty , _characterName = Nothing , _characterDamage = 1 , _characterHitpoints = initialHitpoints + , _speed = defaultSpeed } isDead :: Character -> Bool diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index f2c789d6a6a8..6ea6f93e4254 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -2,44 +2,101 @@ {-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- module Xanthous.Entities.Creature - ( Creature(..) + ( -- * Creature + Creature(..) + -- ** Lenses , creatureType , hitpoints + , hippocampus + + -- ** Creature functions , newWithType , damage , isDead , visionRadius + + -- * Hippocampus + , Hippocampus(..) + -- ** Lenses + , destination + -- ** Destination + , Destination(..) + , destinationFromPos + -- *** Lenses + , destinationPosition + , destinationProgress ) where -------------------------------------------------------------------------------- import Xanthous.Prelude -------------------------------------------------------------------------------- +import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Entities.RawTypes hiding (Creature, description) import Xanthous.Entities (Draw(..), DrawRawChar(..)) +import Xanthous.Data +-------------------------------------------------------------------------------- + +data Destination = Destination + { _destinationPosition :: !Position + -- | The progress towards the destination, tracked as an offset from the + -- creature's original position. + -- + -- When this value reaches >= 1, the creature has reached their destination + , _destinationProgress :: !Tiles + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Destination +instance Arbitrary Destination where arbitrary = genericArbitrary +makeLenses ''Destination + +destinationFromPos :: Position -> Destination +destinationFromPos _destinationPosition = + let _destinationProgress = 0 + in Destination{..} + +data Hippocampus = Hippocampus + { _destination :: !(Maybe Destination) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Hippocampus +instance Arbitrary Hippocampus where arbitrary = genericArbitrary +makeLenses ''Hippocampus + +initialHippocampus :: Hippocampus +initialHippocampus = Hippocampus Nothing + -------------------------------------------------------------------------------- data Creature = Creature - { _creatureType :: CreatureType - , _hitpoints :: Word + { _creatureType :: !CreatureType + , _hitpoints :: !Word + , _hippocampus :: !Hippocampus } deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, CoArbitrary, Function) deriving Draw via DrawRawChar "_creatureType" Creature deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] Creature +instance Arbitrary Creature where arbitrary = genericArbitrary makeLenses ''Creature -instance Arbitrary Creature where - arbitrary = genericArbitrary -------------------------------------------------------------------------------- newWithType :: CreatureType -> Creature newWithType _creatureType = let _hitpoints = _creatureType ^. maxHitpoints + _hippocampus = initialHippocampus in Creature {..} damage :: Word -> Creature -> Creature @@ -53,3 +110,5 @@ isDead = views hitpoints (== 0) visionRadius :: Creature -> Word visionRadius = const 50 -- TODO + +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs index f1f5e05f7aac..fd66140376bb 100644 --- a/src/Xanthous/Entities/RawTypes.hs +++ b/src/Xanthous/Entities/RawTypes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} -------------------------------------------------------------------------------- module Xanthous.Entities.RawTypes @@ -8,6 +8,7 @@ module Xanthous.Entities.RawTypes , isEdible , EntityRaw(..) + , _Creature -- * Lens classes , HasName(..) , HasDescription(..) @@ -17,7 +18,7 @@ module Xanthous.Entities.RawTypes , HasEatMessage(..) , HasHitpointsHealed(..) , HasEdible(..) - , _Creature + , HasSpeed(..) ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -28,16 +29,18 @@ import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Entities (EntityChar, HasChar(..)) import Xanthous.Messages (Message(..)) +import Xanthous.Data (TicksPerTile) -------------------------------------------------------------------------------- data CreatureType = CreatureType - { _name :: Text - , _description :: Text - , _char :: EntityChar - , _maxHitpoints :: Word - , _friendly :: Bool + { _name :: !Text + , _description :: !Text + , _char :: !EntityChar + , _maxHitpoints :: !Word + , _friendly :: !Bool + , _speed :: !TicksPerTile } deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) + deriving anyclass (NFData, CoArbitrary, Function) deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] CreatureType diff --git a/src/Xanthous/Entities/Raws/gormlak.yaml b/src/Xanthous/Entities/Raws/gormlak.yaml index 2441e7e7822e..9a9281c9a91a 100644 --- a/src/Xanthous/Entities/Raws/gormlak.yaml +++ b/src/Xanthous/Entities/Raws/gormlak.yaml @@ -8,5 +8,5 @@ Creature: style: foreground: red maxHitpoints: 5 - speed: 120 + speed: 125 friendly: false diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index 9f247d383325..24c177513ed1 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -9,7 +9,7 @@ import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Edit -------------------------------------------------------------------------------- -import Xanthous.Data (Position(Position), x, y, loc) +import Xanthous.Data (Position'(..), type Position, x, y, loc) import Xanthous.Data.EntityMap (EntityMap, atPosition) import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Entities diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 302d20e1efdc..c437f640c091 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -57,7 +57,8 @@ import Control.Monad.Random.Class import Brick (EventM, Widget) -------------------------------------------------------------------------------- import Xanthous.Data.EntityMap (EntityMap, EntityID) -import Xanthous.Data (Positioned(..), Position(..), Neighbors) +import Xanthous.Data + (Positioned(..), type Position, Neighbors, Ticks(..)) import Xanthous.Orphans () import Xanthous.Game.Prompt import Xanthous.Resource @@ -149,12 +150,12 @@ instance Draw a => Draw (Positioned a) where -------------------------------------------------------------------------------- class Brain a where - step :: Positioned a -> AppM (Positioned a) + step :: Ticks -> Positioned a -> AppM (Positioned a) newtype Brainless a = Brainless a instance Brain (Brainless a) where - step = pure + step = const pure -- | Workaround for the inability to use DerivingVia on Brain due to the lack of -- higher-order roles (specifically AppT not having its last type argument have @@ -162,8 +163,8 @@ instance Brain (Brainless a) where brainVia :: forall brain entity. (Coercible entity brain, Brain brain) => (entity -> brain) -- ^ constructor, ignored - -> (Positioned entity -> AppM (Positioned entity)) -brainVia _ = fmap coerce . step . coerce @_ @(Positioned brain) + -> (Ticks -> Positioned entity -> AppM (Positioned entity)) +brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain) -------------------------------------------------------------------------------- @@ -186,8 +187,8 @@ instance Draw SomeEntity where drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent instance Brain SomeEntity where - step (Positioned pos (SomeEntity ent)) = - fmap SomeEntity <$> step (Positioned pos ent) + step ticks (Positioned pos (SomeEntity ent)) = + fmap SomeEntity <$> step ticks (Positioned pos ent) instance Entity SomeEntity where blocksVision (SomeEntity ent) = blocksVision ent diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 7bcf4da0515e..6b1a57299ea1 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -26,7 +26,7 @@ import Control.Monad.Random import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import Xanthous.Generators.Util import Xanthous.Generators.LevelContents -import Xanthous.Data (Dimensions, Position(Position)) +import Xanthous.Data (Dimensions, Position'(Position), Position) import Xanthous.Data.EntityMap (EntityMap) import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Entities.Environment -- cgit 1.4.1