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.
This commit is contained in:
		
							parent
							
								
									6eba471e24
								
							
						
					
					
						commit
						4ef19aa35a
					
				
					 21 changed files with 719 additions and 32 deletions
				
			
		
							
								
								
									
										35
									
								
								test/Xanthous/DataSpec.hs
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										35
									
								
								test/Xanthous/DataSpec.hs
									
										
									
									
									
										Normal file
									
								
							|  | @ -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 | ||||
|       ] | ||||
|     ] | ||||
|   ] | ||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue