diff options
Diffstat (limited to 'src/Xanthous/Game')
| -rw-r--r-- | src/Xanthous/Game/Lenses.hs | 8 | ||||
| -rw-r--r-- | src/Xanthous/Game/State.hs | 65 |
2 files changed, 61 insertions, 12 deletions
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 7dbd60290144..13f4b89314f7 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -25,7 +25,7 @@ import Xanthous.Data import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Data.EntityMap.Graphics (visiblePositions) import Xanthous.Entities.Character (Character, mkCharacter) -import Xanthous.Entities.Environment (Door, open) +import Xanthous.Entities.Environment (Door, open, GroundMessage) import Xanthous.Entities.Item (Item) import Xanthous.Entities.Creature (Creature) import Xanthous.Entities.Entities () @@ -105,8 +105,12 @@ entityCollision -> Maybe Collision entityCollision Empty = Nothing entityCollision ents + -- TODO track entity collision in the Entity class | any (entityIs @Creature) ents = pure Combat - | all (entityIs @Item) ents = Nothing + | all (\e -> + entityIs @Item e + || entityIs @GroundMessage e + ) ents = Nothing | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door , all (view open) doors = Nothing | otherwise = pure Stop diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 028688542a25..5ddb7de7e9b8 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -------------------------------------------------------------------------------- module Xanthous.Game.State ( GameState(..) @@ -37,10 +37,14 @@ module Xanthous.Game.State , downcastEntity , _SomeEntity , entityIs + -- ** Vias + , Color(..) + , DrawNothing(..) , DrawRawChar(..) , DrawRawCharPriority(..) , DrawCharacter(..) , DrawStyledCharacter(..) + , DeriveEntity(..) -- ** Field classes , HasChar(..) , HasStyle(..) @@ -63,7 +67,7 @@ import Test.QuickCheck.Arbitrary.Generic import Control.Monad.State.Class import Control.Monad.State import Control.Monad.Random.Class -import Brick (EventM, Widget, raw, str) +import Brick (EventM, Widget, raw, str, emptyWidget) import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) import qualified Data.Aeson as JSON import Data.Aeson.Generic.DerivingVia @@ -71,6 +75,7 @@ import Data.Generics.Product.Fields import qualified Graphics.Vty.Attributes as Vty import qualified Graphics.Vty.Image as Vty -------------------------------------------------------------------------------- +import Xanthous.Util (KnownBool(..)) import Xanthous.Data import Xanthous.Data.EntityMap (EntityMap, EntityID) import Xanthous.Data.EntityChar @@ -213,20 +218,29 @@ instance KnownColor 'Magenta where colorVal _ = Vty.magenta instance KnownColor 'Cyan where colorVal _ = Vty.cyan instance KnownColor 'White where colorVal _ = Vty.white -newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where +class KnownMaybeColor (maybeColor :: Maybe Color) where + maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color + +instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing +instance KnownColor color => KnownMaybeColor ('Just color) where + maybeColorVal _ = Just $ colorVal @color Proxy + +newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a instance - ( KnownColor fg - , KnownColor bg + ( KnownMaybeColor fg + , KnownMaybeColor bg , KnownSymbol char ) => Draw (DrawStyledCharacter fg bg char a) where draw _ = raw $ Vty.string attr $ symbolVal @char Proxy where attr = Vty.Attr { Vty.attrStyle = Vty.Default - , Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy - , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy + , Vty.attrForeColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @fg Proxy + , Vty.attrBackColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @bg Proxy , Vty.attrURL = Vty.Default } @@ -235,6 +249,12 @@ instance Draw EntityChar where -------------------------------------------------------------------------------- +newtype DrawNothing (a :: Type) = DrawNothing a + +instance Draw (DrawNothing a) where + draw = const emptyWidget + drawPriority = const 0 + newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a instance @@ -336,6 +356,31 @@ entityIs = isJust . downcastEntity @a _SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a _SomeEntity = prism' SomeEntity downcastEntity +newtype DeriveEntity + (blocksVision :: Bool) + (description :: Symbol) + (entityChar :: Symbol) + (entity :: Type) + = DeriveEntity entity + deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw) + +instance Brain entity => Brain (DeriveEntity b d c entity) where + step = brainVia $ \(DeriveEntity e) -> e + +instance + ( KnownBool blocksVision + , KnownSymbol description + , KnownSymbol entityChar + , Show entity, Eq entity, Ord entity, NFData entity + , ToJSON entity, FromJSON entity + , Draw entity, Brain entity + ) + => Entity (DeriveEntity blocksVision description entityChar entity) where + + blocksVision _ = boolVal @blocksVision + description _ = pack . symbolVal $ Proxy @description + entityChar _ = fromString . symbolVal $ Proxy @entityChar + -------------------------------------------------------------------------------- data DebugState = DebugState |