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.

5 files changed, 122 insertions, 2 deletions

diff --git a/test/Spec.hs b/test/Spec.hs
index 18f034f969a4..c9f3150a744a 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 000000000000..b12e1e895d2e
--- /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 000000000000..c08b568d9eca
--- /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 000000000000..ba060b7ad289
--- /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 000000000000..1f1cc2e4d55e
--- /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
+    ]
+  ]