maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Generate more reasonable doors

Browse source 
Generate doors at more reasonable positions, by:

- Only generating doors at the *ends* of hallways, where there's a
  tee-shaped opening
- Never generating two doors adjacent to each other
This commit is contained in:
Griffin Smith 2020-01-08 23:01:22 -05:00
parent 0f79a06733
commit b6f170c02c
3 changed files with 91 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

36
test/Xanthous/DataSpec.hs
View file

@ -1,9 +1,11 @@
--------------------------------------------------------------------------------
module Xanthous.DataSpec (main, test) where
--------------------------------------------------------------------------------
import Test.Prelude hiding (Right, Left, Down)
import Xanthous.Data
import Test.Prelude hiding (Right, Left, Down, toList, all)
import Data.Group
import Data.Foldable (toList, all)
--------------------------------------------------------------------------------
import Xanthous.Data
--------------------------------------------------------------------------------
main :: IO ()
@ -44,14 +46,14 @@ test = testGroup "Xanthous.Data"
, testProperty "asPosition isUnit" $ \dir ->
dir /= Here ==> isUnit (asPosition 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
[ testCase "Up" $ move Up mempty @?= Position @Int 0 (-1)
, testCase "Down" $ move Down mempty @?= Position @Int 0 1
, testCase "Left" $ move Left mempty @?= Position @Int (-1) 0
, testCase "Right" $ move Right mempty @?= Position @Int 1 0
, testCase "UpLeft" $ move UpLeft mempty @?= Position @Int (-1) (-1)
, testCase "UpRight" $ move UpRight mempty @?= Position @Int 1 (-1)
, testCase "DownLeft" $ move DownLeft mempty @?= Position @Int (-1) 1
, testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1
]
]
@ -79,4 +81,18 @@ test = testGroup "Xanthous.Data"
(Box (V2 4 2) dims)
]
]
, testGroup "Neighbors"
[ testGroup "rotations"
[ testProperty "always has the same members"
$ \(neighs :: Neighbors Int) ->
all (\ns -> sort (toList ns) == sort (toList neighs))
$ rotations neighs
, testProperty "all rotations have the same rotations"
$ \(neighs :: Neighbors Int) ->
let rots = rotations neighs
in all (\ns -> sort (toList $ rotations ns) == sort (toList rots))
rots
]
]
]