about summary refs log blame commit diff
path: root/src/Xanthous/Game/Arbitrary.hs
blob: 886a8c03d786fdef32c6d7f19083766bc2e0337b (plain) (tree)
1
2
3
4
5
6
7
8
                                     
                                     
                                   



                                                                                
                                                  


                                                                                
                                        
                                                                                

                                                     
                                              
                                            
                                    
                                                                

                                                                                

                                                                    

                                  
                               
                                     
                                









                                                                             

                                        
                             
                            
                         

 

                              


                                                                                  
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Arbitrary where
--------------------------------------------------------------------------------
import           Xanthous.Prelude hiding (foldMap)
--------------------------------------------------------------------------------
import           Test.QuickCheck
import           System.Random
import           Data.Foldable (foldMap)
--------------------------------------------------------------------------------
import           Xanthous.Data.Levels
import qualified Xanthous.Data.EntityMap as EntityMap
import           Xanthous.Entities.Entities ()
import           Xanthous.Entities.Character
import           Xanthous.Game.State
import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
--------------------------------------------------------------------------------

deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel

instance Arbitrary GameState where
  arbitrary = do
    chr <- arbitrary @Character
    _upStaircasePosition <- arbitrary
    _messageHistory <- arbitrary
    levs <- arbitrary @(Levels GameLevel)
    _levelRevealedPositions <-
      fmap setFromList
      . sublistOf
      . foldMap (EntityMap.positions . _levelEntities)
      $ levs
    let (_characterEntityID, _levelEntities) =
          EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr)
          $ levs ^. current . levelEntities
        _levels = levs & current .~ GameLevel {..}
    _randomGen <- mkStdGen <$> arbitrary
    let _promptState = NoPrompt -- TODO
    _activePanel <- arbitrary
    _debugState <- arbitrary
    pure $ GameState {..}


instance CoArbitrary GameLevel
instance Function GameLevel
instance CoArbitrary GameState
instance Function GameState
deriving newtype instance CoArbitrary (m (a, GameState)) => CoArbitrary (AppT m a)