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

@@ -15,17 +15,20 @@ category:            Game
 description:         Please see the README on GitHub at <https://github.com/glittershark/xanthous>
 
 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

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 ()

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

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

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

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

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

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

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

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
 
-getInitialState :: IO GameState
-getInitialState = pure 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
+
+characterPosition :: Lens' GameState Position
+characterPosition = positionedCharacter . position

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?"
 
-drawMap :: GameState -> Widget Name
-drawMap _game
-  = viewport MapViewport Both
-  $ vBox mapRows
+drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name
+drawEntities em@(fromNullable . positions -> Just entityPositions)
+  = vBox rows
   where
-    -- TODO
-    firstRow = [str "@"] <> replicate 79 (str " ")
-    mapRows = firstRow <> (replicate 20 . hBox . replicate 80 $ str " ")
+    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
+  = viewport MapViewport Both
+  . 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)

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')

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

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)

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

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
+  ]

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

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
+    ]
+  ]

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
+      ]
+    ]
+  ]

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
+    ]
+  ]

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