1 files changed, 150 insertions, 0 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
new file mode 100644
index 000000000000..6242b855f1cc
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Lenses
+  ( positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , characterVisiblePositions
+  , characterVisibleEntities
+  , getInitialState
+  , initialStateFromSeed
+  , entitiesAtCharacter
+  , revealedEntitiesAtPosition
+
+    -- * 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           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 ()
+--------------------------------------------------------------------------------
+
+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
+        }
+      _autocommand = NoAutocommand
+  in GameState {..}
+
+
+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
+
+visionRadius :: Word
+visionRadius = 12 -- TODO make this dynamic
+
+-- | Update the revealed entities at the character's position based on their
+-- vision
+updateCharacterVision :: GameState -> GameState
+updateCharacterVision game
+  = game & revealedPositions <>~ characterVisiblePositions game
+
+characterVisiblePositions :: GameState -> Set Position
+characterVisiblePositions game =
+  let charPos = game ^. characterPosition
+  in visiblePositions charPos visionRadius $ game ^. entities
+
+characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
+characterVisibleEntities game =
+  let charPos = game ^. characterPosition
+  in visibleEntities charPos visionRadius $ game ^. entities
+
+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 :: Position -> GameState -> (VectorBag SomeEntity)
+revealedEntitiesAtPosition p gs
+  | p `member` characterVisiblePositions gs
+  = entitiesAtPosition
+  | p `member` (gs ^. revealedPositions)
+  = immobileEntitiesAtPosition
+  | otherwise
+  = mempty
+  where
+    entitiesAtPosition = gs ^. entities . EntityMap.atPosition p
+    immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition