9ec51e5123
The test for "one step in each cardinal direction is always visible" was giving a false-negative for an entity at the same position as a wall - not only is this something that would ostensibly never happen, it's also completely reasonable to assume that someone stuck in a wall (due to a bad teleport perhaps?) wouldn't be able to see anything, on account of their head being INSIDE A WALL.
57 lines
2.1 KiB
Haskell
57 lines
2.1 KiB
Haskell
--------------------------------------------------------------------------------
|
|
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"
|