diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Game/Lenses.hs')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Lenses.hs | 178 |
1 files changed, 0 insertions, 178 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs deleted file mode 100644 index c692a3b47944..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Lenses - ( clearMemo - , positionedCharacter - , character - , characterPosition - , updateCharacterVision - , characterVisiblePositions - , characterVisibleEntities - , positionIsCharacterVisible - , getInitialState - , initialStateFromSeed - , entitiesAtCharacter - , revealedEntitiesAtPosition - , hearingRadius - - -- * Collisions - , Collision(..) - , entitiesCollision - , collisionAt - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import System.Random -import Control.Monad.State -import Control.Monad.Random (getRandom) --------------------------------------------------------------------------------- -import Xanthous.Game.State -import qualified Xanthous.Game.Memo as Memo -import Xanthous.Data -import Xanthous.Data.Levels -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Data.EntityMap.Graphics - (visiblePositions, visibleEntities) -import Xanthous.Data.VectorBag -import Xanthous.Entities.Character (Character, mkCharacter) -import {-# SOURCE #-} Xanthous.Entities.Entities () -import Xanthous.Game.Memo (emptyMemoState, MemoState) -import Xanthous.Data.Memo (fillWithM, Memoized) --------------------------------------------------------------------------------- - -getInitialState :: IO GameState -getInitialState = initialStateFromSeed <$> getRandom - -initialStateFromSeed :: Int -> GameState -initialStateFromSeed seed = - let _randomGen = mkStdGen seed - chr = mkCharacter - _upStaircasePosition = Position 0 0 - (_characterEntityID, _levelEntities) - = EntityMap.insertAtReturningID - _upStaircasePosition - (SomeEntity chr) - mempty - _levelRevealedPositions = mempty - level = GameLevel {..} - _levels = oneLevel level - _messageHistory = mempty - _promptState = NoPrompt - _activePanel = Nothing - _debugState = DebugState - { _allRevealed = False - } - _savefile = Nothing - _autocommand = NoAutocommand - _memo = emptyMemoState - in GameState {..} - -clearMemo :: MonadState GameState m => Lens' MemoState (Memoized k v) -> m () -clearMemo l = memo %= Memo.clear l - -positionedCharacter :: Lens' GameState (Positioned Character) -positionedCharacter = lens getPositionedCharacter setPositionedCharacter - where - setPositionedCharacter :: GameState -> Positioned Character -> GameState - setPositionedCharacter game chr - = game - & entities . at (game ^. characterEntityID) - ?~ fmap SomeEntity chr - - getPositionedCharacter :: GameState -> Positioned Character - getPositionedCharacter game - = over positioned - ( fromMaybe (error "Invariant error: Character was not a character!") - . downcastEntity - ) - . fromMaybe (error "Invariant error: Character not found!") - $ EntityMap.lookupWithPosition - (game ^. characterEntityID) - (game ^. entities) - - -character :: Lens' GameState Character -character = positionedCharacter . positioned - -characterPosition :: Lens' GameState Position -characterPosition = positionedCharacter . position - --- TODO make this dynamic -visionRadius :: Word -visionRadius = 12 - --- TODO make this dynamic -hearingRadius :: Word -hearingRadius = 12 - --- | Update the revealed entities at the character's position based on their --- vision -updateCharacterVision :: GameState -> GameState -updateCharacterVision = execState $ do - positions <- characterVisiblePositions - revealedPositions <>= positions - -characterVisiblePositions :: MonadState GameState m => m (Set Position) -characterVisiblePositions = do - charPos <- use characterPosition - fillWithM - (memo . Memo.characterVisiblePositions) - charPos - (uses entities $ visiblePositions charPos visionRadius) - -characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity -characterVisibleEntities game = - let charPos = game ^. characterPosition - in visibleEntities charPos visionRadius $ game ^. entities - -positionIsCharacterVisible :: MonadState GameState m => Position -> m Bool -positionIsCharacterVisible p = (p `elem`) <$> characterVisiblePositions --- ^ TODO optimize - -entitiesCollision - :: ( Functor f - , forall xx. MonoFoldable (f xx) - , Element (f SomeEntity) ~ SomeEntity - , Element (f (Maybe Collision)) ~ Maybe Collision - , Show (f (Maybe Collision)) - , Show (f SomeEntity) - ) - => f SomeEntity - -> Maybe Collision -entitiesCollision = join . maximumMay . fmap entityCollision - -collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) -collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision - -entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity) -entitiesAtCharacter = lens getter setter - where - getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition) - setter gs ents = gs - & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents - --- | Returns all entities at the given position that are revealed to the --- character. --- --- Concretely, this is either entities that are *currently* visible to the --- character, or entities, that are immobile and that the character has seen --- before -revealedEntitiesAtPosition - :: MonadState GameState m - => Position - -> m (VectorBag SomeEntity) -revealedEntitiesAtPosition p = do - allRev <- use $ debugState . allRevealed - cvps <- characterVisiblePositions - entitiesAtPosition <- use $ entities . EntityMap.atPosition p - revealed <- use revealedPositions - let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition - pure $ if | allRev || p `member` cvps - -> entitiesAtPosition - | p `member` revealed - -> immobileEntitiesAtPosition - | otherwise - -> mempty |