Add 'users/glittershark/xanthous/' from commit '53b56744f4'
git-subtree-dir: users/glittershark/xanthous git-subtree-mainline:91f53f02d8git-subtree-split:53b56744f4
This commit is contained in:
Vincent Ambo
commit
2edb963b97
96 changed files with 10030 additions and 0 deletions
|
|
@ -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
|
||||
]
|
||||
]
|
||||
|
|
@ -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
|
||||
]
|
||||
|
|
@ -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"
|
||||
|
|
@ -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)
|
||||
]
|
||||
]
|
||||
66
users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs
Normal file
66
users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs
Normal file
|
|
@ -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
|
||||
]
|
||||
]
|
||||
|
|
@ -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)
|
||||
]
|
||||
Loading…
Add table
Add a link
Reference in a new issue