Tweak gormlak movement slightly

- Don't let gormlaks run into things like walls or each other
- Add a small element of randomness to gormlaks' motion
- Increase gormlaks' vision by a large amount

package.yaml

@@ -41,6 +41,9 @@ dependencies:
 - mtl
 - optparse-applicative
 - random
+- random-fu
+- random-extras
+- random-source
 - raw-strings-qq
 - reflection
 - stache

src/Xanthous/AI/Gormlak.hs

@@ -6,25 +6,43 @@ import           Xanthous.Prelude hiding (lines)
 --------------------------------------------------------------------------------
 import           Data.Coerce
 import           Control.Monad.State
+import           Control.Monad.Random
 --------------------------------------------------------------------------------
-import           Xanthous.Data (Positioned(..))
+import           Xanthous.Data (Positioned(..), positioned)
+import           Xanthous.Data.EntityMap
 import qualified Xanthous.Entities.Creature as Creature
 import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Entities.Character (Character)
 import qualified Xanthous.Entities.RawTypes as Raw
 import           Xanthous.Entities (Entity(..), Brain(..), brainVia)
-import           Xanthous.Game.State (entities, GameState)
+import           Xanthous.Game.State (entities, GameState, entityIs)
+import           Xanthous.Game.Lenses (Collision(..), collisionAt)
 import           Xanthous.Data.EntityMap.Graphics (linesOfSight)
+import           Xanthous.Random
 --------------------------------------------------------------------------------
 
-stepGormlak :: MonadState GameState m => Positioned Creature -> m (Positioned Creature)
+stepGormlak
-stepGormlak (Positioned pos creature) = do
+  :: (MonadState GameState m, MonadRandom m)
+  => Positioned Creature
+  -> m (Positioned Creature)
+stepGormlak pe@(Positioned pos creature) = do
   lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature)
+  line <- choose $ weightedBy length lines
+  -- traceShowM ("current position", pos)
+  -- traceShowM ("lines", (headMay <=< tailMay) <$> lines)
   let newPos = fromMaybe pos
                $ fmap fst
-               . headMay <=< tailMay <=< headMay
+               . headMay
-               . sortOn (Down . length)
+               =<< tailMay
-               $ lines
+               =<< line
-  pure $ Positioned newPos creature
+  collisionAt newPos >>= \case
+    Nothing -> pure $ Positioned newPos creature
+    Just Stop -> pure pe
+    Just Combat -> do
+      ents <- use $ entities . atPosition newPos
+      if | any (entityIs @Creature) ents -> pure pe
+         | any (entityIs @Character) ents -> undefined
+         | otherwise -> pure pe
 
 newtype GormlakBrain = GormlakBrain Creature
 

src/Xanthous/App.hs

@@ -57,11 +57,6 @@ makeApp = pure $ Brick.App
 runAppM :: AppM a -> GameState -> EventM Name a
 runAppM appm = fmap fst . runAppT appm
 
--- testGormlak :: Creature
--- testGormlak =
---   let Just (Creature gormlak) = raw "gormlak"
---   in Creature.newWithType gormlak
-
 startEvent :: AppM ()
 startEvent = do
   initLevel
@@ -264,20 +259,3 @@ attackAt pos =
         say ["combat", "hit"] msgParams
         entities . ix creatureID . positioned .= SomeEntity creature'
     stepGame
-
-data Collision
-  = Stop
-  | Combat
-  deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass (NFData)
-
-collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
-collisionAt pos = do
-  ents <- use $ entities . EntityMap.atPosition pos
-  pure $
-    if | null ents -> Nothing
-       | any (entityIs @Creature) ents -> pure Combat
-       | all (entityIs @Item) ents -> Nothing
-       | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
-       , all (view open) doors -> Nothing
-       | otherwise -> pure Stop

src/Xanthous/Entities/Creature.hs

@@ -52,4 +52,4 @@ isDead :: Creature -> Bool
 isDead = views hitpoints (== 0)
 
 visionRadius :: Creature -> Word
-visionRadius = const 12 -- TODO
+visionRadius = const 50 -- TODO

src/Xanthous/Game.hs

@@ -19,6 +19,10 @@ module Xanthous.Game
   , popMessage
   , hideMessage
 
+    -- * Collisions
+  , Collision(..)
+  , collisionAt
+
     -- * App monad
   , AppT(..)
 

src/Xanthous/Game/Lenses.hs

@@ -6,17 +6,25 @@ module Xanthous.Game.Lenses
   , characterPosition
   , updateCharacterVision
   , getInitialState
+
+    -- * Collisions
+  , Collision(..)
+  , collisionAt
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
 --------------------------------------------------------------------------------
 import           System.Random
+import           Control.Monad.State
 --------------------------------------------------------------------------------
 import           Xanthous.Game.State
 import           Xanthous.Data
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.EntityMap.Graphics (visiblePositions)
 import           Xanthous.Entities.Character (Character, mkCharacter)
+import           Xanthous.Entities.Environment (Door, open)
+import           Xanthous.Entities.Item (Item)
+import           Xanthous.Entities.Creature (Creature)
 --------------------------------------------------------------------------------
 
 getInitialState :: IO GameState
@@ -31,6 +39,9 @@ getInitialState = do
       _messageHistory = NoMessageHistory
       _revealedPositions = mempty
       _promptState = NoPrompt
+      _debugState = DebugState
+        { _allRevealed = False
+        }
   pure GameState {..}
 
 
@@ -70,3 +81,20 @@ updateCharacterVision game =
   let charPos = game ^. characterPosition
       visible = visiblePositions charPos visionRadius $ game ^. entities
   in game & revealedPositions <>~ visible
+
+data Collision
+  = Stop
+  | Combat
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData)
+
+collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
+collisionAt pos = do
+  ents <- use $ entities . EntityMap.atPosition pos
+  pure $
+    if | null ents -> Nothing
+       | any (entityIs @Creature) ents -> pure Combat
+       | all (entityIs @Item) ents -> Nothing
+       | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
+       , all (view open) doors -> Nothing
+       | otherwise -> pure Stop

src/Xanthous/Random.hs

@@ -1,14 +1,34 @@
-{-# LANGUAGE TupleSections #-}
+--------------------------------------------------------------------------------
 {-# LANGUAGE UndecidableInstances #-}
-
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
 module Xanthous.Random
   ( Choose(..)
   , ChooseElement(..)
+  , Weighted(..)
+  , evenlyWeighted
+  , weightedBy
   ) where
-
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
+--------------------------------------------------------------------------------
 import Data.List.NonEmpty (NonEmpty)
-import Control.Monad.Random.Class (MonadRandom(getRandomR))
+import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom))
+import Data.Random.Shuffle.Weighted
+import Data.Random.Distribution
+import Data.Random.Distribution.Uniform
+import Data.Random.Distribution.Uniform.Exclusive
+import Data.Random.Sample
+import qualified Data.Random.Source as DRS
+--------------------------------------------------------------------------------
+
+instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where
+  getRandomWord8 = getRandom
+  getRandomWord16 = getRandom
+  getRandomWord32 = getRandom
+  getRandomWord64 = getRandom
+  getRandomDouble = getRandom
+  getRandomNByteInteger n = getRandomR (0, 256 ^ n)
 
 class Choose a where
   type RandomResult a
@@ -37,3 +57,22 @@ instance MonoFoldable a => Choose (NonNull a) where
 instance Choose (NonEmpty a) where
   type RandomResult (NonEmpty a) = a
   choose = choose . fromNonEmpty @[_]
+
+newtype Weighted w t a = Weighted (t (w, a))
+
+evenlyWeighted :: [a] -> Weighted Int [] a
+evenlyWeighted = Weighted . itoList
+
+weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a
+weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs
+
+instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w [] a) where
+  type RandomResult (Weighted w [] a) = Maybe a
+  choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws
+
+instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w NonEmpty a) where
+  type RandomResult (Weighted w NonEmpty a) = a
+  choose (Weighted ws) =
+    sample
+    $ fromMaybe (error "unreachable") . headMay
+    <$> weightedSample 1 (toList ws)

xanthous.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 121c6fd553f5e73ac5ff4c89f17eacc3a85997255aba87390943a418b439896c
+-- hash: ad4acf50f6be0dc7ae6c68d9920b61c2d32b5d759aae7311a124d159b4a9bc7f
 
 name:           xanthous
 version:        0.1.0.0
@@ -96,6 +96,9 @@ library
     , quickcheck-instances
     , quickcheck-text
     , random
+    , random-extras
+    , random-fu
+    , random-source
     , raw-strings-qq
     , reflection
     , stache
@@ -173,6 +176,9 @@ executable xanthous
     , quickcheck-instances
     , quickcheck-text
     , random
+    , random-extras
+    , random-fu
+    , random-source
     , raw-strings-qq
     , reflection
     , stache
@@ -228,6 +234,9 @@ test-suite test
     , quickcheck-instances
     , quickcheck-text
     , random
+    , random-extras
+    , random-fu
+    , random-source
     , raw-strings-qq
     , reflection
     , stache