From 4ef19aa35a6d63a8d9f7b6a7a11ac82c2a525783 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 31 Aug 2019 13:17:27 -0400 Subject: Add entities, and allow walking around Add support for entities via a port of the EntityMap type, and implement command support starting at basic hjkl. --- package.yaml | 19 +++-- src/Main.hs | 2 +- src/Xanthous/App.hs | 16 +++- src/Xanthous/Command.hs | 20 +++++ src/Xanthous/Data.hs | 118 ++++++++++++++++++++++++++++++ src/Xanthous/Data/EntityMap.hs | 141 ++++++++++++++++++++++++++++++++++++ src/Xanthous/Entities.hs | 64 ++++++++++++++++ src/Xanthous/Entities/Character.hs | 21 ++++++ src/Xanthous/Entities/SomeEntity.hs | 34 +++++++++ src/Xanthous/Game.hs | 67 ++++++++++++++++- src/Xanthous/Game/Draw.hs | 35 ++++++--- src/Xanthous/Orphans.hs | 23 ++++++ src/Xanthous/Prelude.hs | 5 +- src/Xanthous/Resource.hs | 2 + src/Xanthous/Util.hs | 14 ++++ test/Spec.hs | 15 +++- test/Test/Prelude.hs | 18 +++++ test/Xanthous/Data/EntityMapSpec.hs | 26 +++++++ test/Xanthous/DataSpec.hs | 35 +++++++++ test/Xanthous/GameSpec.hs | 30 ++++++++ xanthous.cabal | 44 +++++++++-- 21 files changed, 718 insertions(+), 31 deletions(-) create mode 100644 src/Xanthous/Command.hs create mode 100644 src/Xanthous/Data.hs create mode 100644 src/Xanthous/Data/EntityMap.hs create mode 100644 src/Xanthous/Entities.hs create mode 100644 src/Xanthous/Entities/Character.hs create mode 100644 src/Xanthous/Entities/SomeEntity.hs create mode 100644 src/Xanthous/Orphans.hs create mode 100644 src/Xanthous/Util.hs create mode 100644 test/Test/Prelude.hs create mode 100644 test/Xanthous/Data/EntityMapSpec.hs create mode 100644 test/Xanthous/DataSpec.hs create mode 100644 test/Xanthous/GameSpec.hs diff --git a/package.yaml b/package.yaml index 4a450cfd5d..cc5002d80f 100644 --- a/package.yaml +++ b/package.yaml @@ -15,17 +15,20 @@ category: Game description: Please see the README on GitHub at dependencies: -- base -- lens -- containers -- constraints - QuickCheck +- base +- brick +- checkers - classy-prelude -- mtl +- constraints +- containers - data-default - deepseq -- ascii-art-to-unicode -- brick +- generic-arbitrary +- generic-monoid +- groups +- lens +- mtl - vty default-extensions: @@ -34,6 +37,7 @@ default-extensions: - DeriveAnyClass - DeriveGeneric - DerivingStrategies +- DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies @@ -77,3 +81,4 @@ tests: - tasty - tasty-hunit - tasty-quickcheck + - lens-properties diff --git a/src/Main.hs b/src/Main.hs index 1cd4e94457..de867067b9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,6 +12,6 @@ ui = str "Hello, world!" main :: IO () main = do app <- makeApp - initialState <- getInitialState + let initialState = getInitialState _ <- defaultMain app initialState pure () diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 5c0383c38e..bf5ec68abb 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -4,10 +4,13 @@ import Xanthous.Prelude import Brick hiding (App) import qualified Brick import Graphics.Vty.Attributes (defAttr) +import Graphics.Vty.Input.Events (Event(EvResize, EvKey)) import Xanthous.Game import Xanthous.Game.Draw (drawGame) import Xanthous.Resource (Name) +import Xanthous.Command +import Xanthous.Data (move) type App = Brick.App GameState () Name @@ -15,7 +18,18 @@ makeApp :: IO App makeApp = pure $ Brick.App { appDraw = drawGame , appChooseCursor = const headMay - , appHandleEvent = resizeOrQuit + , appHandleEvent = handleEvent , appStartEvent = pure , appAttrMap = const $ attrMap defAttr [] } + +handleEvent :: GameState -> BrickEvent Name () -> EventM Name (Next GameState) +handleEvent game (VtyEvent (EvKey k mods)) + | Just command <- commandFromKey k mods + = handleCommand command game +handleEvent game _ = continue game + +handleCommand :: Command -> GameState -> EventM Name (Next GameState) +handleCommand Quit = halt +handleCommand (Move dir) = continue . (characterPosition %~ move dir) +handleCommand _ = undefined diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs new file mode 100644 index 0000000000..50fe4abb45 --- /dev/null +++ b/src/Xanthous/Command.hs @@ -0,0 +1,20 @@ +module Xanthous.Command where + +import Graphics.Vty.Input (Key(..), Modifier(..)) + +import Xanthous.Prelude hiding (Left, Right, Down) +import Xanthous.Data (Direction(..)) + +data Command + = Quit + | Move Direction + | PickUp + | PreviousMessage + +commandFromKey :: Key -> [Modifier] -> Maybe Command +commandFromKey (KChar 'q') [] = Just Quit +commandFromKey (KChar 'h') [] = Just $ Move Left +commandFromKey (KChar 'j') [] = Just $ Move Down +commandFromKey (KChar 'k') [] = Just $ Move Up +commandFromKey (KChar 'l') [] = Just $ Move Right +commandFromKey _ _ = Nothing diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs new file mode 100644 index 0000000000..773f1adc91 --- /dev/null +++ b/src/Xanthous/Data.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | Common data types for Xanthous +-------------------------------------------------------------------------------- +module Xanthous.Data + ( Position(..) + , x + , y + + , Positioned(..) + , position + , positioned + , loc + + -- * + , Direction(..) + , opposite + , move + , asPosition + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Left, Down, Right) +import Test.QuickCheck (Arbitrary, CoArbitrary, Function) +import Test.QuickCheck.Arbitrary.Generic +import Data.Group +import Brick (Location(Location)) +-------------------------------------------------------------------------------- +import Xanthous.Util (EqEqProp(..), EqProp) +-------------------------------------------------------------------------------- + +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 + +instance Arbitrary Position where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Semigroup Position where + (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂) + +instance Monoid Position where + mempty = Position 0 0 + +instance Group Position where + invert (Position px py) = Position (-px) (-py) + +data Positioned a where + Positioned :: Position -> a -> Positioned a + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving anyclass (CoArbitrary, Function) + +instance Arbitrary a => Arbitrary (Positioned a) where + arbitrary = Positioned <$> arbitrary <*> arbitrary + +position :: Lens' (Positioned a) Position +position = lens + (\(Positioned pos _) -> pos) + (\(Positioned _ a) pos -> Positioned pos a) + +positioned :: Lens (Positioned a) (Positioned b) a b +positioned = lens + (\(Positioned _ x') -> x') + (\(Positioned pos _) x' -> Positioned pos x') + +loc :: Iso' Position Location +loc = iso hither yon + where + hither (Position px py) = Location (px, py) + yon (Location (lx, ly)) = Position lx ly + +-------------------------------------------------------------------------------- + +data Direction where + Up :: Direction + Down :: Direction + Left :: Direction + Right :: Direction + UpLeft :: Direction + UpRight :: Direction + DownLeft :: Direction + DownRight :: Direction + deriving stock (Show, Eq, Generic) + +instance Arbitrary Direction where + arbitrary = genericArbitrary + shrink = genericShrink + +opposite :: Direction -> Direction +opposite Up = Down +opposite Down = Up +opposite Left = Right +opposite Right = Left +opposite UpLeft = DownRight +opposite UpRight = DownLeft +opposite DownLeft = UpRight +opposite DownRight = UpLeft + +move :: Direction -> Position -> Position +move Up = y -~ 1 +move Down = y +~ 1 +move Left = x -~ 1 +move Right = x +~ 1 +move UpLeft = move Up . move Left +move UpRight = move Up . move Right +move DownLeft = move Down . move Left +move DownRight = move Down . move Right + +asPosition :: Direction -> Position +asPosition dir = move dir mempty diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs new file mode 100644 index 0000000000..e3ceb6f651 --- /dev/null +++ b/src/Xanthous/Data/EntityMap.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} + +module Xanthous.Data.EntityMap + ( EntityMap + , EntityID + , emptyEntityMap + , insertAt + , insertAtReturningID + , atPosition + , positions + , lookup + , lookupWithPosition + -- , positionedEntities + ) where + +import Data.Monoid (Endo(..)) +import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck.Checkers (EqProp) + +import Xanthous.Prelude hiding (lookup) +import Xanthous.Data (Position, Positioned(..), positioned, position) +import Xanthous.Orphans () +import Xanthous.Util (EqEqProp(..)) + +type EntityID = Word32 +type NonNullVector a = NonNull (Vector a) + +data EntityMap a where + EntityMap :: + { _byPosition :: Map Position (NonNullVector EntityID) + , _byID :: HashMap EntityID (Positioned a) + , _lastID :: EntityID + } -> EntityMap a + deriving stock (Functor, Foldable, Traversable) +deriving via (EqEqProp (EntityMap a)) instance Eq a => EqProp (EntityMap a) +makeLenses ''EntityMap + +byIDInvariantError :: forall a. a +byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition " + <> "must point to entityIDs in byID" + +instance Eq a => Eq (EntityMap a) where + em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap + +instance Show a => Show (EntityMap a) where + show em = "_EntityMap # " <> show (em ^. _EntityMap) + +instance Arbitrary a => Arbitrary (EntityMap a) where + arbitrary = review _EntityMap <$> arbitrary + +type instance Index (EntityMap a) = EntityID +type instance IxValue (EntityMap a) = (Positioned a) +instance Ixed (EntityMap a) where ix eid = at eid . traverse + +instance At (EntityMap a) where + at eid = lens (view $ byID . at eid) setter + where + setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a + setter m Nothing = fromMaybe m $ do + Positioned pos _ <- m ^. byID . at eid + pure $ m + & removeEIDAtPos pos + & byID . at eid .~ Nothing + setter m (Just (Positioned pos e)) = + case lookupWithPosition eid m of + Nothing -> insertAt pos e m + Just (Positioned origPos _) -> m + & removeEIDAtPos origPos + & byID . ix eid . position .~ pos + & byPosition . at pos %~ \case + Nothing -> Just $ ncons eid mempty + Just es -> Just $ eid <| es + removeEIDAtPos pos = + byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid)) + +emptyEntityMap :: EntityMap a +emptyEntityMap = EntityMap mempty mempty 0 + +_EntityMap :: Iso' (EntityMap a) [(Position, a)] +_EntityMap = iso hither yon + where + hither :: EntityMap a -> [(Position, a)] + hither em = do + (pos, eids) <- em ^. byPosition . _Wrapped + eid <- toList eids + ent <- em ^.. byID . at eid . folded . positioned + pure (pos, ent) + yon :: [(Position, a)] -> EntityMap a + yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap + +instance Semigroup (EntityMap a) where + em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₁ ^. _EntityMap) em₂ + +instance Monoid (EntityMap a) where + mempty = emptyEntityMap + + +insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a) +insertAtReturningID pos e em = + let (eid, em') = em & lastID <+~ 1 + in em' + & byID . at eid ?~ Positioned pos e + & byPosition . at pos %~ \case + Nothing -> Just $ ncons eid mempty + Just es -> Just $ eid <| es + & (eid, ) + +insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a +insertAt pos e = snd . insertAtReturningID pos e + +atPosition :: forall a. Position -> Lens' (EntityMap a) (Vector a) +atPosition pos = lens getter setter + where + getter em = + let + eids :: Vector EntityID + eids = maybe mempty toNullable $ em ^. byPosition . at pos + + getEIDAssume :: EntityID -> a + getEIDAssume eid = fromMaybe byIDInvariantError + $ em ^? byID . ix eid . positioned + in getEIDAssume <$> eids + setter em Empty = em & byPosition . at pos .~ Nothing + setter em entities = alaf Endo foldMap (insertAt pos) entities em + +positions :: EntityMap a -> [Position] +positions = toListOf $ byPosition . to keys . folded + +lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a) +lookupWithPosition eid = view $ byID . at eid + +lookup :: EntityID -> EntityMap a -> Maybe a +lookup eid = fmap (view positioned) . lookupWithPosition eid + +-- unlawful :( +-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b) +-- positionedEntities = byID . itraversed diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs new file mode 100644 index 0000000000..6851a7a5d5 --- /dev/null +++ b/src/Xanthous/Entities.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Xanthous.Entities + ( Draw(..) + , DrawCharacter(..) + , DrawStyledCharacter(..) + , Entity + + , Color(..) + , KnownColor(..) + ) where + +import Xanthous.Prelude +import Brick +import Data.Typeable +import qualified Graphics.Vty.Attributes as Vty +import qualified Graphics.Vty.Image as Vty + +class Draw a where + draw :: a -> Widget n + +newtype DrawCharacter (char :: Symbol) (a :: Type) where + DrawCharacter :: a -> DrawCharacter char a + +instance KnownSymbol char => Draw (DrawCharacter char a) where + draw _ = str $ symbolVal @char Proxy + +-------------------------------------------------------------------------------- + +data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + +class KnownColor (color :: Color) where + colorVal :: forall proxy. proxy color -> Vty.Color + +instance KnownColor 'Black where colorVal _ = Vty.black +instance KnownColor 'Red where colorVal _ = Vty.red +instance KnownColor 'Green where colorVal _ = Vty.green +instance KnownColor 'Yellow where colorVal _ = Vty.yellow +instance KnownColor 'Blue where colorVal _ = Vty.blue +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 + DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a + +instance + ( KnownColor fg + , KnownColor 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.attrURL = Vty.Default + } + +-------------------------------------------------------------------------------- + +class (Show a, Eq a, Draw a) => Entity a +instance (Show a, Eq a, Draw a) => Entity a diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs new file mode 100644 index 0000000000..5cf397e822 --- /dev/null +++ b/src/Xanthous/Entities/Character.hs @@ -0,0 +1,21 @@ +module Xanthous.Entities.Character + ( Character(..) + , mkCharacter + ) where + +import Xanthous.Prelude +import Test.QuickCheck + +import Xanthous.Entities + +data Character where + Character :: Character + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function) + deriving Draw via (DrawCharacter "@" Character) + +instance Arbitrary Character where + arbitrary = pure Character + +mkCharacter :: Character +mkCharacter = Character diff --git a/src/Xanthous/Entities/SomeEntity.hs b/src/Xanthous/Entities/SomeEntity.hs new file mode 100644 index 0000000000..029247de9b --- /dev/null +++ b/src/Xanthous/Entities/SomeEntity.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs #-} +module Xanthous.Entities.SomeEntity + ( SomeEntity(..) + , downcastEntity + ) where + +import Xanthous.Prelude +import Test.QuickCheck (Arbitrary(..)) +import qualified Test.QuickCheck.Gen as Gen + +import Xanthous.Entities (Draw(..), Entity) +import Data.Typeable +import Xanthous.Entities.Character + +data SomeEntity where + SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity + +instance Show SomeEntity where + show (SomeEntity x) = "SomeEntity (" <> show x <> ")" + +instance Eq SomeEntity where + (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of + Just Refl -> a == b + _ -> False + +instance Arbitrary SomeEntity where + arbitrary = Gen.oneof + [pure $ SomeEntity Character] + +instance Draw SomeEntity where + draw (SomeEntity ent) = draw ent + +downcastEntity :: (Entity a, Typeable a) => SomeEntity -> Maybe a +downcastEntity (SomeEntity e) = cast e diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index c88509819c..3ca00afbbd 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -1,12 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} module Xanthous.Game ( GameState(..) + , entities , getInitialState + + , positionedCharacter + , character + , characterPosition ) where import Xanthous.Prelude +import Test.QuickCheck.Arbitrary + +import Xanthous.Data.EntityMap (EntityMap, EntityID) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Data (Positioned, Position(..), positioned, position) +import Xanthous.Entities +import Xanthous.Entities.SomeEntity +import Xanthous.Entities.Character data GameState = GameState - { } + { _entities :: EntityMap SomeEntity + , _characterEntityID :: EntityID + } + deriving stock (Show, Eq) +makeLenses ''GameState + +instance Arbitrary GameState where + arbitrary = do + ents <- arbitrary + char <- arbitrary + pure $ getInitialState + & entities .~ ents + & positionedCharacter .~ char + +getInitialState :: GameState +getInitialState = + let char = mkCharacter + (_characterEntityID, _entities) + = EntityMap.insertAtReturningID + (Position 0 0) + (SomeEntity char) + mempty + in GameState {..} + +positionedCharacter :: Lens' GameState (Positioned Character) +positionedCharacter = lens getPositionedCharacter setPositionedCharacter + where + setPositionedCharacter :: GameState -> Positioned Character -> GameState + setPositionedCharacter game char + = game + & entities . at (game ^. characterEntityID) + ?~ fmap SomeEntity char + + getPositionedCharacter :: GameState -> Positioned Character + getPositionedCharacter game + = over positioned + ( fromMaybe (error "Invariant error: Character was not a character!") + . downcastEntity + ) + . fromMaybe (error "Invariant error: Character not found!") + $ EntityMap.lookupWithPosition + (game ^. characterEntityID) + (game ^. entities) + + +character :: Lens' GameState Character +character = positionedCharacter . positioned -getInitialState :: IO GameState -getInitialState = pure GameState +characterPosition :: Lens' GameState Position +characterPosition = positionedCharacter . position diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index 2d793ba27b..79089029ea 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -1,28 +1,45 @@ +{-# LANGUAGE ViewPatterns #-} + module Xanthous.Game.Draw ( drawGame ) where import Xanthous.Prelude -import Brick +import Brick hiding (loc) import Brick.Widgets.Border import Brick.Widgets.Border.Style -import Xanthous.Game (GameState(..)) +import Xanthous.Data (Position(Position), x, y, loc) +import Xanthous.Data.EntityMap +import Xanthous.Entities +import Xanthous.Game (GameState(..), entities, characterPosition) import Xanthous.Resource (Name(..)) drawMessages :: GameState -> Widget Name drawMessages _ = str "Welcome to Xanthous! It's dangerous out there, why not stay inside?" +drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name +drawEntities em@(fromNullable . positions -> Just entityPositions) + = vBox rows + where + maxPosition = maximum entityPositions + maxY = maxPosition ^. y + maxX = maxPosition ^. x + rows = mkRow <$> [0..maxY] + mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] + renderEntityAt pos = maybe (str " ") draw $ em ^? atPosition pos . folded +drawEntities _ = emptyWidget + drawMap :: GameState -> Widget Name -drawMap _game +drawMap game = viewport MapViewport Both - $ vBox mapRows - where - -- TODO - firstRow = [str "@"] <> replicate 79 (str " ") - mapRows = firstRow <> (replicate 20 . hBox . replicate 80 $ str " ") + . showCursor Character (game ^. characterPosition . loc) + . drawEntities + $ game ^. entities drawGame :: GameState -> [Widget Name] -drawGame game = pure . withBorderStyle unicode +drawGame game + = pure + . withBorderStyle unicode $ drawMessages game <=> border (drawMap game) diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs new file mode 100644 index 0000000000..232eabf4ef --- /dev/null +++ b/src/Xanthous/Orphans.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UndecidableInstances, PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | + +module Xanthous.Orphans () where + +import Xanthous.Prelude + +instance forall s a. + ( Cons s s a a + , MonoFoldable s + ) => Cons (NonNull s) (NonNull s) a a where + _Cons = prism hither yon + where + hither :: (a, NonNull s) -> NonNull s + hither (a, ns) = + let s = toNullable ns + in impureNonNull $ a <| s + + yon :: NonNull s -> Either (NonNull s) (a, NonNull s) + yon ns = case ns ^? _Cons of + Nothing -> Left ns + Just (a, ns') -> Right (a, ns') diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs index e75c11d7bb..b769c4fe90 100644 --- a/src/Xanthous/Prelude.hs +++ b/src/Xanthous/Prelude.hs @@ -3,8 +3,11 @@ module Xanthous.Prelude , Type , Constraint , module GHC.TypeLits + , module Control.Lens ) where -import ClassyPrelude hiding (return) +import ClassyPrelude hiding + (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index) import Data.Kind import GHC.TypeLits hiding (Text) +import Control.Lens diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs index 2310a68cc2..aa9020903c 100644 --- a/src/Xanthous/Resource.hs +++ b/src/Xanthous/Resource.hs @@ -6,6 +6,8 @@ import Xanthous.Prelude data Name = MapViewport -- ^ The main viewport where we display the game content + | Character + -- ^ The character | MessageBox -- ^ The box where we display messages to the user deriving stock (Show, Eq, Ord) diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs new file mode 100644 index 0000000000..377b66cf15 --- /dev/null +++ b/src/Xanthous/Util.hs @@ -0,0 +1,14 @@ +module Xanthous.Util + ( EqEqProp(..) + , EqProp(..) + ) where + +import Xanthous.Prelude + +import Test.QuickCheck.Checkers + +newtype EqEqProp a = EqEqProp a + deriving newtype Eq + +instance Eq a => EqProp (EqEqProp a) where + (=-=) = eq diff --git a/test/Spec.hs b/test/Spec.hs index 18f034f969..c9f3150a74 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,14 @@ --- | +import Test.Prelude +import qualified Xanthous.DataSpec +import qualified Xanthous.Data.EntityMapSpec +import qualified Xanthous.GameSpec -module Spec where +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous" + [ Xanthous.DataSpec.test + , Xanthous.Data.EntityMapSpec.test + , Xanthous.GameSpec.test + ] diff --git a/test/Test/Prelude.hs b/test/Test/Prelude.hs new file mode 100644 index 0000000000..b12e1e895d --- /dev/null +++ b/test/Test/Prelude.hs @@ -0,0 +1,18 @@ +module Test.Prelude + ( module Xanthous.Prelude + , module Test.Tasty + , module Test.Tasty.HUnit + , module Test.Tasty.QuickCheck + , module Test.QuickCheck.Classes + , testBatch + ) where + +import Xanthous.Prelude hiding (assert, elements) +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit +import Test.QuickCheck.Classes +import Test.QuickCheck.Checkers (TestBatch) + +testBatch :: TestBatch -> TestTree +testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs new file mode 100644 index 0000000000..c08b568d9e --- /dev/null +++ b/test/Xanthous/Data/EntityMapSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ApplicativeDo #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityMapSpec where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import Xanthous.Data.EntityMap +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data.EntityMap" + [ testBatch $ monoid @(EntityMap Int) mempty + , testGroup "Eq laws" + [ testProperty "reflexivity" $ \(em :: EntityMap Int) -> + em == em + , testProperty "symmetric" $ \(em₁ :: EntityMap Int) em₂ -> + (em₁ == em₂) == (em₂ == em₁) + , testProperty "transitive" $ \(em₁ :: EntityMap Int) em₂ em₃ -> + if (em₁ == em₂ && em₂ == em₃) + then (em₁ == em₃) + else True + ] + ] diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs new file mode 100644 index 0000000000..ba060b7ad2 --- /dev/null +++ b/test/Xanthous/DataSpec.hs @@ -0,0 +1,35 @@ +-- | + +module Xanthous.DataSpec where + +import Test.Prelude hiding (Right, Left, Down) +import Xanthous.Data +import Data.Group + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Data" + [ testGroup "Position" + [ testBatch $ monoid @Position mempty + , testProperty "group laws" $ \(pos :: Position) -> + pos <> invert pos == mempty && invert pos <> pos == mempty + ] + , testGroup "Direction" + [ testProperty "opposite is involutive" $ \(dir :: Direction) -> + opposite (opposite dir) == dir + , testProperty "opposite provides inverse" $ \dir -> + invert (asPosition dir) == asPosition (opposite dir) + , testGroup "Move" + [ testCase "Up" $ move Up mempty @?= Position 0 (-1) + , testCase "Down" $ move Down mempty @?= Position 0 1 + , testCase "Left" $ move Left mempty @?= Position (-1) 0 + , testCase "Right" $ move Right mempty @?= Position 1 0 + , testCase "UpLeft" $ move UpLeft mempty @?= Position (-1) (-1) + , testCase "UpRight" $ move UpRight mempty @?= Position 1 (-1) + , testCase "DownLeft" $ move DownLeft mempty @?= Position (-1) 1 + , testCase "DownRight" $ move DownRight mempty @?= Position 1 1 + ] + ] + ] diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs new file mode 100644 index 0000000000..1f1cc2e4d5 --- /dev/null +++ b/test/Xanthous/GameSpec.hs @@ -0,0 +1,30 @@ +module Xanthous.GameSpec where + +import Test.Prelude hiding (Down) +import Xanthous.Game +import Control.Lens.Properties +import Xanthous.Data (move, Direction(Down)) +import Xanthous.Data.EntityMap (atPosition) +import Xanthous.Entities.SomeEntity + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Game" + [ testGroup "positionedCharacter" + [ testProperty "lens laws" $ isLens positionedCharacter + , testCase "updates the position of the character" $ do + let initialGame = getInitialState + initialPos = initialGame ^. characterPosition + updatedGame = initialGame & characterPosition %~ move Down + updatedPos = updatedGame ^. characterPosition + updatedPos @?= move Down initialPos + updatedGame ^. entities . atPosition initialPos @?= fromList [] + updatedGame ^. entities . atPosition updatedPos + @?= fromList [SomeEntity $ initialGame ^. character] + ] + , testGroup "characterPosition" + [ testProperty "lens laws" $ isLens characterPosition + ] + ] diff --git a/xanthous.cabal b/xanthous.cabal index f4dd1bcafd..162540b202 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 82abd26f60a9ec818eed37784bf7d873658bb40772a67205c42977a98a108566 +-- hash: d069cdc1d0657c9b140465b8156b86722d399db49289c8352cccb2a70ab548e0 name: xanthous version: 0.1.0.0 @@ -30,26 +30,37 @@ library exposed-modules: Main Xanthous.App + Xanthous.Command + Xanthous.Data + Xanthous.Data.EntityMap + Xanthous.Entities + Xanthous.Entities.Character + Xanthous.Entities.SomeEntity Xanthous.Game Xanthous.Game.Draw + Xanthous.Orphans Xanthous.Prelude Xanthous.Resource + Xanthous.Util other-modules: Paths_xanthous hs-source-dirs: src - default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators + default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators ghc-options: -Wall -threaded build-depends: QuickCheck - , ascii-art-to-unicode , base , brick + , checkers , classy-prelude , constraints , containers , data-default , deepseq + , generic-arbitrary + , generic-monoid + , groups , lens , mtl , vty @@ -59,25 +70,36 @@ executable xanthous main-is: Main.hs other-modules: Xanthous.App + Xanthous.Command + Xanthous.Data + Xanthous.Data.EntityMap + Xanthous.Entities + Xanthous.Entities.Character + Xanthous.Entities.SomeEntity Xanthous.Game Xanthous.Game.Draw + Xanthous.Orphans Xanthous.Prelude Xanthous.Resource + Xanthous.Util Paths_xanthous hs-source-dirs: src - default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators + default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators ghc-options: -Wall -threaded build-depends: QuickCheck - , ascii-art-to-unicode , base , brick + , checkers , classy-prelude , constraints , containers , data-default , deepseq + , generic-arbitrary + , generic-monoid + , groups , lens , mtl , vty @@ -88,22 +110,30 @@ test-suite test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Test.Prelude + Xanthous.Data.EntityMapSpec + Xanthous.DataSpec + Xanthous.GameSpec Paths_xanthous hs-source-dirs: test - default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators + default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators ghc-options: -Wall -threaded -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck - , ascii-art-to-unicode , base , brick + , checkers , classy-prelude , constraints , containers , data-default , deepseq + , generic-arbitrary + , generic-monoid + , groups , lens + , lens-properties , mtl , tasty , tasty-hunit -- cgit 1.4.1