about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
diff options
context:
space:
mode:
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Game/Lenses.hs')
-rw-r--r--users/grfn/xanthous/src/Xanthous/Game/Lenses.hs178
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