diff options
Diffstat (limited to 'users/aspen/xanthous/src/Xanthous/Game/Lenses.hs')
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Game/Lenses.hs | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs b/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs new file mode 100644 index 0000000000..c692a3b479 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs @@ -0,0 +1,178 @@ +{-# 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 |