Add 'users/glittershark/xanthous/' from commit '53b56744f4335c038724a1bcffc27a7eb8cf6a6d' r/978

git-subtree-dir: users/glittershark/xanthous
git-subtree-mainline: 91f53f02d8479303910abfd3f3690d3ef27e6c4b
git-subtree-split: 53b56744f4335c038724a1bcffc27a7eb8cf6a6d

6 files changed, 258 insertions, 0 deletions

diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs
new file mode 100644
index 000000000000..e403503743c0
--- /dev/null
+++ b/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs
@@ -0,0 +1,28 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntitiesSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.Entities
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.Entities"
+  [ testGroup "Collision"
+    [ testProperty "JSON round-trip" $ \(c :: Collision) ->
+        JSON.decode (JSON.encode c) === Just c
+    , testGroup "JSON encoding examples"
+      [ testCase "Stop" $ JSON.encode Stop @?= "\"Stop\""
+      , testCase "Combat" $ JSON.encode Combat @?= "\"Combat\""
+      ]
+    ]
+  , testGroup "EntityAttributes"
+    [ testProperty "JSON round-trip" $ \(ea :: EntityAttributes) ->
+        JSON.decode (JSON.encode ea) === Just ea
+    ]
+  ]
diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs
new file mode 100644
index 000000000000..9e8024c9d223
--- /dev/null
+++ b/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs
@@ -0,0 +1,18 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityCharSpec where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.EntityChar
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.EntityChar"
+  [ testProperty "JSON round-trip" $ \(ec :: EntityChar) ->
+      JSON.decode (JSON.encode ec) === Just ec
+  ]
diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
new file mode 100644
index 000000000000..fd37548ce864
--- /dev/null
+++ b/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
@@ -0,0 +1,57 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap.GraphicsSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+import Data.Aeson
+--------------------------------------------------------------------------------
+import Xanthous.Game.State
+import Xanthous.Data
+import Xanthous.Data.EntityMap
+import Xanthous.Data.EntityMap.Graphics
+import Xanthous.Entities.Environment (Wall(..))
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.EntityMap.Graphics"
+  [ testGroup "visiblePositions"
+    [ testProperty "one step in each cardinal direction is always visible"
+      $ \pos (Cardinal dir) (Positive r) (wallPositions :: Set Position)->
+          pos `notMember` wallPositions ==>
+          let em = review _EntityMap . map (, Wall) . toList $ wallPositions
+              em' = em & atPosition (move dir pos) %~ (Wall <|)
+              poss = visiblePositions pos r em'
+          in counterexample ("visiblePositions: " <> show poss)
+             $ move dir pos `member` poss
+    , testGroup "bugs"
+      [ testCase "non-contiguous bug 1"
+        $ let charPos = Position 20 20
+              gormlakPos = Position 17 19
+              em = insertAt gormlakPos TestEntity
+                   . insertAt charPos TestEntity
+                   $ mempty
+              visPositions = visiblePositions charPos 12 em
+          in (gormlakPos `member` visPositions) @?
+             ( "not ("
+             <> show gormlakPos <> " `member` "
+             <> show visPositions
+             <> ")"
+             )
+      ]
+    ]
+  ]
+
+--------------------------------------------------------------------------------
+
+data TestEntity = TestEntity
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (ToJSON, FromJSON, NFData)
+
+instance Brain TestEntity where
+  step _ = pure
+instance Draw TestEntity
+instance Entity TestEntity where
+  description _ = ""
+  entityChar _ = "e"
diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs
new file mode 100644
index 000000000000..7c5cad019616
--- /dev/null
+++ b/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE ApplicativeDo #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMapSpec where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.EntityMap
+import           Xanthous.Data (Positioned(..))
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = localOption (QuickCheckTests 20)
+  $ testGroup "Xanthous.Data.EntityMap"
+  [ testBatch $ monoid @(EntityMap Int) mempty
+  , testGroup "Deduplicate"
+    [ testGroup "Semigroup laws"
+      [ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c ->
+          a <> (b <> c) === (a <> b) <> c
+      ]
+    ]
+  , 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
+    ]
+  , testGroup "JSON encoding/decoding"
+    [ testProperty "round-trips" $ \(em :: EntityMap Int) ->
+        let em' = JSON.decode (JSON.encode em)
+        in counterexample (show (em' ^? _Just . lastID, em ^. lastID
+                                , em' ^? _Just . byID == em ^. byID . re _Just
+                                , em' ^? _Just . byPosition == em ^. byPosition . re _Just
+                                , em' ^? _Just . _EntityMap == em ^. _EntityMap . re _Just
+                                ))
+           $ em' === Just em
+    , testProperty "Preserves IDs" $ \(em :: EntityMap Int) ->
+        let Just em' = JSON.decode $ JSON.encode em
+        in toEIDsAndPositioned em' === toEIDsAndPositioned em
+    ]
+
+  , localOption (QuickCheckTests 50)
+  $ testGroup "atPosition"
+    [ testProperty "setget" $ \pos (em :: EntityMap Int) es ->
+        view (atPosition pos) (set (atPosition pos) es em) === es
+    , testProperty "getset" $ \pos (em :: EntityMap Int) ->
+        set (atPosition pos) (view (atPosition pos) em) em === em
+    , testProperty "setset" $ \pos (em :: EntityMap Int) es ->
+        (set (atPosition pos) es . set (atPosition pos) es) em
+        ===
+        set (atPosition pos) es em
+      -- testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos
+    , testProperty "preserves IDs" $ \(em :: EntityMap Int) e1 e2 p ->
+        let (eid, em') = insertAtReturningID p e1 em
+            em'' = em' & atPosition p %~ (e2 <|)
+        in
+          counterexample ("em': " <> show em')
+          . counterexample ("em'': " <> show em'')
+          $ em'' ^. at eid === Just (Positioned p e1)
+    ]
+  ]
diff --git a/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs
new file mode 100644
index 000000000000..4e46946a93b0
--- /dev/null
+++ b/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs
@@ -0,0 +1,66 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.LevelsSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import Xanthous.Util (between)
+import Xanthous.Data.Levels
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.Levels"
+  [ testGroup "current"
+    [ testProperty "view is extract" $ \(levels :: Levels Int) ->
+        levels ^. current === extract levels
+    , testProperty "set replaces current" $ \(levels :: Levels Int) new ->
+        extract (set current new levels) === new
+    , testProperty "set extract is id" $ \(levels :: Levels Int) ->
+        set current (extract levels) levels === levels
+    , testProperty "set y ∘ set x ≡ set y" $ \(levels :: Levels Int) x y ->
+        set current y (set current x levels) === set current y levels
+    ]
+  , localOption (QuickCheckTests 20)
+  $ testBatch $ semigroup @(Levels Int) (error "unused", 1 :: Int)
+  , testGroup "next/prev"
+    [ testGroup "nextLevel"
+      [ testProperty "seeks forwards" $ \(levels :: Levels Int) genned ->
+          (pos . runIdentity . nextLevel (Identity genned) $ levels)
+          === pos levels + 1
+      , testProperty "maintains the invariant" $ \(levels :: Levels Int) genned ->
+          let levels' = runIdentity . nextLevel (Identity genned) $ levels
+          in between 0 (length levels') $ pos levels'
+      , testProperty "extract is total" $ \(levels :: Levels Int) genned ->
+          let levels' = runIdentity . nextLevel (Identity genned) $ levels
+          in total $ extract levels'
+      , testProperty "uses the generated level as the next level"
+        $ \(levels :: Levels Int) genned ->
+          let levels' = seek (length levels - 1) levels
+              levels'' = runIdentity . nextLevel (Identity genned) $ levels'
+          in counterexample (show levels'')
+             $ extract levels'' === genned
+      ]
+    , testGroup "prevLevel"
+      [ testProperty "seeks backwards" $ \(levels :: Levels Int) ->
+          case prevLevel levels of
+            Nothing -> property Discard
+            Just levels' -> pos levels' === pos levels - 1
+      , testProperty "maintains the invariant" $ \(levels :: Levels Int) ->
+          case prevLevel levels of
+            Nothing -> property Discard
+            Just levels' -> property $ between 0 (length levels') $ pos levels'
+      , testProperty "extract is total" $ \(levels :: Levels Int) ->
+          case prevLevel levels of
+            Nothing -> property Discard
+            Just levels' -> total $ extract levels'
+      ]
+    ]
+  , testGroup "JSON"
+    [ testProperty "toJSON/parseJSON round-trip" $ \(levels :: Levels Int) ->
+        JSON.decode (JSON.encode levels) === Just levels
+    ]
+  ]
diff --git a/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs
new file mode 100644
index 000000000000..acf7a67268f4
--- /dev/null
+++ b/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs
@@ -0,0 +1,20 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.NestedMapSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck.Instances.Semigroup ()
+--------------------------------------------------------------------------------
+import qualified Xanthous.Data.NestedMap as NM
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.NestedMap"
+  [ testProperty "insert/lookup" $ \nm ks v ->
+      let nm' = NM.insert ks v nm
+      in counterexample ("inserted: " <> show nm')
+         $ NM.lookup @Map @Int @Int ks nm' === Just (NM.Val v)
+  ]