diff -w -B -a -d -u -b --new-file 13_utility/src/GameCore.hs 14_utility_annotate/src/GameCore.hs

--- 13_utility/src/GameCore.hs

+++ 14_utility_annotate/src/GameCore.hs

@@ -8,11 +8,14 @@

 module GameCore where

 import           Protolude hiding (Map)

+import qualified Numeric as Num

 import qualified Data.Text as Txt

 import           Data.Map.Strict (Map)

+import           Data.DList (DList)

 import qualified Data.Aeson as Ae

 import qualified System.Random as Rnd

 import           Control.Lens.TH (makeLenses)

+import           Control.Monad.Writer.Strict (Writer)

 import qualified GameHost as Host

 import qualified EntityType as E

@@ -24,6 +27,9 @@

 newtype Aid = Aid Text deriving (Show, Eq, Ord)

+type UtilAnnotator m = Writer (DList UtilAnnotationEntry) m

+

+

 data Actor = Actor { _acId :: !Aid

                    , _acClass :: !ActorClass

                    , _acEntity :: !Entity

@@ -36,12 +42,13 @@

                    , _acMoveEnergyCost :: !Int

                    , _acSkipMove :: !Bool

-

                    -- | List of utilities in order of execution

                    --    Note that the world is threaded through the utilities and can be updated (i.e. in the ([], World) result)

                    --    The array of results has an updated actor and a score. These are speculative, and are only applied

                    --    if that utility is selected. The world updates are kept even if nothing is selected

-                   , _acUtilities :: ![World -> Actor -> [PathTo] -> ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)]

+

+                   , _acUtilities :: ![World -> Actor -> [PathTo] -> UtilAnnotator ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)]

+

                    -- | The actor's disposition - the values that define the actors personality

                    , _acDisposition :: !Disposition

@@ -62,6 +68,9 @@

                    , _wdActors :: !(Map Aid Actor)

                    , _wdMinMoveEnergy :: !Int   -- ^ min energy required before any more, regardless of cost, can be attempted

                    , _wdEnergyIncrements :: !Int -- ^ amount of energy that is added per game loop

+

+                   , _wdUtilBrainAnnotations :: ![(E.EntityType, [UtilAnnotationEntry], [UtilAnnotationEntry])]

+

                    }

 data Config = Config { _cfgKeys :: !(Map Text Text)

@@ -107,18 +113,23 @@

             | PathToActor Path Actor WorldPos

             | PathToPlayer Path Player WorldPos

-

-

 data Impulse = ImpMoveTowards Path

              | ImpMoveRandom

-

-

+             deriving (Show)

 data Disposition = Disposition { _dsSmitten :: Float

                                , _dsWanderlust :: Float

                                , _dsWanderlustToExits :: Float

                                , _dsSmittenWith :: [E.EntityType]

-                               } 

+                               } deriving (Show)

+

+

+data UtilAnnotationEntry = UeAt Text

+                         | UeSelectTopNone Text

+                         | UeSelectTopAbove Float 

+                         | UeSelectTopOne Float Text Impulse Text

+                         | UeNote Text

+                         deriving (Show)

 ----------------------------------------------------------------------------------------

@@ -179,6 +190,9 @@

     mkLower t = Txt.toLower (Txt.take 1 t) <> Txt.drop 1 t

 ----------------------------------------------------------------------------------------

+showF :: Float -> Text

+showF x = Txt.pack $ Num.showFFloat (Just 2) x ""

+

 makeLenses ''World

 makeLenses ''Config

 makeLenses ''Player

diff -w -B -a -d -u -b --new-file 13_utility/src/GameEngine.hs 14_utility_annotate/src/GameEngine.hs

--- 13_utility/src/GameEngine.hs

+++ 14_utility_annotate/src/GameEngine.hs

@@ -11,6 +11,7 @@

 import qualified Data.Map.Strict as Map

 import qualified Data.List as Lst

 import qualified Data.List.Index as Lst

+import qualified Data.DList as DLst

 import qualified Data.Text as Txt

 import qualified Data.Text.IO as Txt

 import qualified Data.Text.Encoding as TxtE

@@ -20,6 +21,7 @@

 import qualified System.Random as Rnd

 import           Control.Lens (at, _1, (^.), (.~), (%~))

 import qualified Control.Arrow as Ar

+import           Control.Monad.Writer.Strict (runWriter)

 import           Control.Concurrent.STM (atomically, readTVar, newTVar, modifyTVar', TVar)

 import           GameCore

@@ -107,6 +109,7 @@

                                           ]

                , _wdMinMoveEnergy = 100

                , _wdEnergyIncrements = 20

+               , _wdUtilBrainAnnotations = []

                }

   in

   -- Calculate the actors fov

@@ -205,6 +208,15 @@

                                       )

       -- Get the updated world

       w2 <- atomically $ readTVar worldV

+

+      -- Handle the annotations

+      -- This is not terribly pretty as its doing a select for update, but its good enough for debugging

+      -- the annotation code can be removed once everything is working

+

+      let annotations = w2 ^. wdUtilBrainAnnotations 

+      atomically $ modifyTVar' worldV (\w -> w & wdUtilBrainAnnotations .~ [])

+      printAnnotations annotations

+

       -- Draw

       drawAndSend w2

@@ -214,6 +226,36 @@

   where

     updatePlayer f = atomically $ modifyTVar' worldV (\w -> w & wdPlayer %~ f)

+    printAnnotations as = do

+      putText ""

+      putText ""

+      putText ""

+      putText ""

+      putText "***** Utility Annotations **************"

+      traverse_ printAnnotation as

+      putText "****************************************"

+      putText ""

+

+    printAnnotation (e, assess, top)  = do

+      putText ""

+      putText $ "-----------------------" <> show e

+      putText "  -- assess --"

+      putText . Txt.intercalate "\n" $ showEntries <$> assess

+      putText ""

+      putText "  -- top --"

+      putText . Txt.intercalate "\n" $ showEntries <$> top

+      putText "-----------------------"

+

+    showEntries :: UtilAnnotationEntry -> Text

+    showEntries e =

+      case e of

+        UeAt a -> "    At: " <> a

+        UeSelectTopNone n -> "    No utils: " <> n

+        UeSelectTopAbove f  -> "    Top above: " <> showF f

+        UeSelectTopOne val n i d -> "    Select top one: " <> n <> ", impulse=" <> show i <> ", score=" <> showF val <> "," <> d

+        UeNote n -> "    Note: " <> n

+

+

 sendLog :: Host.Connection -> Text -> IO ()

 sendLog conn err =

@@ -756,13 +798,18 @@

       let mv aOrig wOrig =

             let

               inFov = findPathToAllInFov wOrig aOrig 

-              (utilities, wNext) = UB.assessUtilities inFov wOrig aOrig 

+              ((utilities, wNext), annAssess) = runWriter $ UB.assessUtilities inFov wOrig aOrig 

+              (topUtil, annTop) = runWriter $ UB.selectTopUtility utilities

+

+

+              annotation = (aOrig ^. acEntity ^. enType, DLst.toList annAssess, DLst.toList annTop)

+              addAnn w' = w' & wdUtilBrainAnnotations %~ (annotation :)

             in

-            case UB.selectTopUtility utilities of

+            case topUtil of

               Nothing ->

                 -- No utility = no move, skip

-                updateActorById wNext (aOrig ^. acId) (\a -> a & acSkipMove .~ True)

+                updateActorById (addAnn wNext) (aOrig ^. acId) (\a -> a & acSkipMove .~ True)

               Just (_, actorIfMoved, action, _, _) ->

                 let cost = floor . fromIntegral $ aOrig ^. acMoveEnergyCost in

@@ -773,7 +820,8 @@

                   -- the next actor move (i.e. avoid looping)

                   wNext & wdActors %~ Map.insert (aOrig ^. acId) (aOrig & acSkipMove .~ True)

                 else

-                  actOnImpulse cost wNext actorIfMoved action

+                  actOnImpulse cost (addAnn wNext) actorIfMoved action

+

       in

       let actorsThatCanMove = filter

diff -w -B -a -d -u -b --new-file 13_utility/src/UtilityBrain.hs 14_utility_annotate/src/UtilityBrain.hs

--- 13_utility/src/UtilityBrain.hs

+++ 14_utility_annotate/src/UtilityBrain.hs

@@ -15,15 +14,21 @@

 import Protolude 

 import qualified Data.List as Lst

+import qualified Data.DList as DLst

 import qualified System.Random as Rnd

 import qualified Control.Arrow as Ar

 import           Control.Lens

+import           Control.Monad.Writer.Strict (tell, MonadWriter)

 import           GameCore

 import qualified EntityType as E

+telld :: MonadWriter (DLst.DList a) m => a -> m ()

+telld t = tell (DLst.singleton t)

+

+

 path :: PathTo -> Path

 path (PathToEntity p _ _) = p

 path (PathToActor p _ _) = p

@@ -29,15 +34,19 @@

 path (PathToActor p _ _) = p

 path (PathToPlayer p _ _) = p

-

-

 selectTopUtility :: [(Float, Actor, Impulse, Text, Maybe PathTo)]

-                 -> Maybe (Float, Actor, Impulse, Text, Maybe PathTo)

-selectTopUtility rs = 

+                 -> UtilAnnotator (Maybe (Float, Actor, Impulse, Text, Maybe PathTo))

+selectTopUtility rs = do

+  telld $ UeAt "select top"

+

   case rs of

-      [] -> Nothing

+      [] -> do

+        telld $ UeSelectTopNone "No utilities"

+        pure Nothing

+

+      (u@(v0,a0,i0,n0,_):_) -> do

+        telld $ UeSelectTopAbove (v0 - 0.001)

-      (u@(v0,a0,_,_,_):_) -> do

         -- Get the results with the top scores (fuzzy match)

         let top = Lst.takeWhile (\(v2,_,_,_,_) -> v2 >= v0 - 0.001) rs 

@@ -47,40 +56,36 @@

               (Rnd.randomR (0, length top - 1) rndA, rndB') 

         case atMay top idx of

-          Just (s, a, i, n, p) -> Just (s, a & acStdGen .~ rndB, i, n, p)

-

-          Nothing -> Just u

-

+          Just (s, a, i, n, p) -> do

+            telld $ UeSelectTopOne s n i "selected"

+            pure $ Just (s, a & acStdGen .~ rndB, i, n, p)

+          Nothing -> do

+            telld $ UeSelectTopOne v0 n0 i0 $ "Nothing at index, using zero: " <> show idx

+            pure $ Just u

 -- | See the docs on acUtilities

 -- | Mainly that the world is threaded through utilities and any updates are kept even if no/other utilities are selected

 -- | The actor in the results are speculative and only the actor for the selected utility gets used

-assessUtilities :: [PathTo] -> World -> Actor -> ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

-assessUtilities paths world actor =

-  let

-    (rs, wNext) = foldl' assess ([], world) (actor ^. acUtilities)

-    ranked = rankUtility rs

-  in

-  (ranked, wNext)

-  where

-    assess (hist, w) u =

-      let

-        a = fromMaybe actor $ w ^. wdActors ^.at (actor ^. acId) 

-        (rs, wNext) = u w a paths

-      in

-      (hist <> rs, wNext)

+assessUtilities :: [PathTo] -> World -> Actor -> UtilAnnotator ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

+assessUtilities paths world actor = do

+  (rs, wNext) <- foldM assess ([], world) (actor ^. acUtilities)

+  ranked <- rankUtility rs

+  pure (ranked, wNext)

+  where

+    assess (hist, w) u = do

+      let a = fromMaybe actor $ w ^. wdActors ^.at (actor ^. acId) 

+      (rs, wNext) <- u w a paths

+      pure (hist <> rs, wNext)

-rankUtility :: [(Float, Actor, Impulse, Text, Maybe PathTo)] -> [(Float, Actor, Impulse, Text, Maybe PathTo)]

+rankUtility :: [(Float, Actor, Impulse, Text, Maybe PathTo)] -> UtilAnnotator [(Float, Actor, Impulse, Text, Maybe PathTo)]

 rankUtility us = 

-  Lst.reverse $ Lst.sortOn (\(x, _, _, _, _) -> x) us

-

-

+  pure . Lst.reverse $ Lst.sortOn (\(x, _, _, _, _) -> x) us

 clamp :: Float -> Float

@@ -129,35 +130,36 @@

         Just $ distance / maxDist

+utilityOfWander :: World -> Actor -> [PathTo] -> UtilAnnotator ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

+utilityOfWander world actor _paths = do

+  telld $ UeAt "Wander"

+  let rule = clamp $ 0.02 * (10 * clamp (actor ^. acDisposition ^. dsWanderlust)) 

+  pure ([(rule, actor, ImpMoveRandom, "wander", Nothing)], world)

-utilityOfWander :: World -> Actor -> [PathTo] -> ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

-utilityOfWander world actor _paths = 

-  let rule = clamp $ 0.02 * (10 * clamp (actor ^. acDisposition ^. dsWanderlust)) in

-  ([(rule, actor, ImpMoveRandom, "wander", Nothing)], world)

+utilityOfWanderToExit :: World -> Actor -> [PathTo] -> UtilAnnotator ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

+utilityOfWanderToExit world actor allPaths = do

+  telld $ UeAt "WanderToExit"

+  let rule x = clamp $ 1 - (0.04 * x + (1.24 - clamp (actor ^. acDisposition ^. dsWanderlustToExits))) 

+  let clampedResults = moveTowardsUtil [E.Door] rule allPaths actor

+  pure ((\(p, score) -> (score, actor, ImpMoveTowards (path p), "wander to exit", Just p)) <$> clampedResults, world)

-utilityOfWanderToExit :: World -> Actor -> [PathTo] -> ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

-utilityOfWanderToExit world actor allPaths =

-  let

-    rule x = clamp $ 1 - (0.04 * x + (1.24 - clamp (actor ^. acDisposition ^. dsWanderlustToExits))) 

-    clampedResults = moveTowardsUtil [E.Door] rule allPaths actor

-  in

-  ((\(p, score) -> (score, actor, ImpMoveTowards (path p), "wander to exit", Just p)) <$> clampedResults, world)

-

+utilityOfInfatuation :: World -> Actor -> [PathTo] -> UtilAnnotator ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

+utilityOfInfatuation world actor allPaths = do

+  telld . UeAt $ "Infatuation: " <> show (length allPaths) -- debugShowPathTos allPaths --show (actor ^. acDisposition ^. dsSmitten)

+  let rule x = clamp $ -x ** 4 + clamp (actor ^. acDisposition ^. dsSmitten) 

+  let clampedResults = moveTowardsUtil (actor ^. acDisposition ^. dsSmittenWith) rule allPaths actor

-utilityOfInfatuation :: World -> Actor -> [PathTo] -> ([(Float, Actor, Impulse, Text, Maybe PathTo)], World)

-utilityOfInfatuation world actor allPaths =

-  let

-    rule x = clamp $ -x ** 4 + clamp (actor ^. acDisposition ^. dsSmitten) 

-    clampedResults = moveTowardsUtil (actor ^. acDisposition ^. dsSmittenWith) rule allPaths actor

-  in

-  ((\(p, score) -> (score, actor, ImpMoveTowards (path p), "infatuation", Just p)) <$> clampedResults, world)

+  let (r, _) = ((\(p, score) -> (score, actor, ImpMoveTowards (path p), "infatuation", Just p)) <$> clampedResults, world)

+  let r2 = (\(f, _, _, _, _) -> showF f) <$> r

+  telld . UeNote $ "infatuation: " <> show r2

+  pure ((\(p, score) -> (score, actor, ImpMoveTowards (path p), "infatuation", Just p)) <$> clampedResults, world)