Track whether robots have an ID number or not at the type level (#311)

See the discussion at
#303 (comment) .
This seems like an unqualified success: no more hacky (-1)'s, and
doing the refactoring actually uncovered a bug!  Previously, we were
not actually assigning ID's to the robots that were read as part of a
challenge.  This means that in a challenge with multiple robots, all
but one of them would instantly disappear since they all shared the
same ID number.

LICENSE

@@ -1,4 +1,4 @@
-Copyright Brent Yorgey 2021
+Copyright Brent Yorgey 2021-2022
 SPDX-License-Identifier: BSD-3-Clause
 
 All rights reserved.

bench/Benchmark.hs

@@ -9,12 +9,13 @@ import Control.Monad.Except (runExceptT)
 import Control.Monad.State (evalStateT, execStateT)
 import Criterion.Main (Benchmark, bench, bgroup, defaultConfig, defaultMainWith, whnfAppIO)
 import Criterion.Types (Config (timeLimit))
+import qualified Data.Functor.Const as F
 import Data.Int (Int64)
 import Linear.V2 (V2 (V2))
 import Swarm.Game.CESK (emptyStore, initMachine)
 import Swarm.Game.Display (defaultRobotDisplay)
-import Swarm.Game.Robot (Robot, mkRobot)
-import Swarm.Game.State (GameState, GameType (ClassicGame), addRobot, creativeMode, initGameState, world)
+import Swarm.Game.Robot (URobot, mkRobot)
+import Swarm.Game.State (GameState, GameType (ClassicGame), addURobot, creativeMode, initGameState, world)
 import Swarm.Game.Step (gameTick)
 import Swarm.Game.Terrain (TerrainType (DirtT))
 import Swarm.Game.World (newWorld)
@@ -70,17 +71,17 @@ circlerProgram =
   |]
 
 -- | Initializes a robot with program prog at location loc facing north.
-initRobot :: ProcessedTerm -> V2 Int64 -> Robot
-initRobot prog loc = mkRobot (-1) Nothing "" [] north loc defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False
+initRobot :: ProcessedTerm -> V2 Int64 -> URobot
+initRobot prog loc = mkRobot (F.Const ()) Nothing "" [] north loc defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False
 
 -- | Creates a GameState with numRobot copies of robot on a blank map, aligned
 --   in a row starting at (0,0) and spreading east.
-mkGameState :: (V2 Int64 -> Robot) -> Int -> IO GameState
+mkGameState :: (V2 Int64 -> URobot) -> Int -> IO GameState
 mkGameState robotMaker numRobots = do
   let robots = [robotMaker (V2 (fromIntegral x) 0) | x <- [0 .. numRobots -1]]
   Right initState <- runExceptT (initGameState (ClassicGame 0))
   execStateT
-    (mapM addRobot robots)
+    (mapM addURobot robots)
     ( initState
         & creativeMode .~ True
         & world .~ newWorld (const (fromEnum DirtT, Nothing))

src/Swarm/Game/Challenge.hs

@@ -47,7 +47,7 @@ import Linear.V2
 import Witch (from, into)
 
 import Swarm.Game.Entity
-import Swarm.Game.Robot (Robot)
+import Swarm.Game.Robot (URobot)
 import Swarm.Game.Terrain
 import Swarm.Game.World
 import Swarm.Game.WorldGen (testWorld2FromArray)
@@ -61,7 +61,7 @@ data Challenge = Challenge
   , _challengeSeed :: Maybe Int
   , _challengeEntities :: EntityMap
   , _challengeWorld :: WorldFun Int Entity
-  , _challengeRobots :: [Robot]
+  , _challengeRobots :: [URobot]
   , _challengeWin :: ProcessedTerm
   }
 
@@ -93,7 +93,7 @@ challengeWorld :: Lens' Challenge (WorldFun Int Entity)
 
 -- | The starting robots for the challenge.  Note this should
 --   include the "base".
-challengeRobots :: Lens' Challenge [Robot]
+challengeRobots :: Lens' Challenge [URobot]
 
 -- | The winning condition for the challenge, expressed as a
 --   program of type @cmd bool@.  By default, this program will be

src/Swarm/Game/Robot.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- |
 -- Module      :  Swarm.Game.Robot
@@ -21,7 +25,9 @@ module Swarm.Game.Robot (
 
   -- * Robots
   RID,
+  RobotR,
   Robot,
+  URobot,
 
   -- * Robot context
   RobotContext,
@@ -53,7 +59,7 @@ module Swarm.Game.Robot (
   -- ** Create
   mkRobot,
   baseRobot,
-  unsafeSetRobotID,
+  setRobotID,
 
   -- ** Query
   robotKnows,
@@ -121,9 +127,10 @@ makeLenses ''LogEntry
 -- | A unique identifier for a robot.
 type RID = Int
 
--- | A value of type 'Robot' is a record representing the state of a
---   single robot.
-data Robot = Robot
+-- | A value of type 'RobotR' is a record representing the state of a
+--   single robot.  The @f@ parameter is for tracking whether or not
+--   the robot has been assigned a unique ID.
+data RobotR f = RobotR
   { _robotEntity :: Entity
   , _installedDevices :: Inventory
   , -- | A cached view of the capabilities this robot has.
@@ -133,14 +140,15 @@ data Robot = Robot
   , _robotLogUpdated :: Bool
   , _robotLocation :: V2 Int64
   , _robotContext :: RobotContext
-  , _robotID :: RID
+  , _robotID :: f RID -- Might or might not have an ID yet!
   , _robotParentID :: Maybe RID
   , _machine :: CESK
   , _systemRobot :: Bool
   , _selfDestruct :: Bool
   , _tickSteps :: Int
   }
-  deriving (Show)
+
+deriving instance Show (f RID) => Show (RobotR f)
 
 -- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/
 -- for the approach used here with lenses.
@@ -152,7 +160,17 @@ let exclude = ['_robotCapabilities, '_installedDevices, '_robotLog, '_robotID]
           & lensField . mapped . mapped %~ \fn n ->
             if n `elem` exclude then [] else fn n
       )
-      ''Robot
+      ''RobotR
+
+-- | An Unidentified robot, i.e. a robot record without a unique ID number.
+type URobot = RobotR (Const ())
+
+-- | A robot with a unique ID number.
+type Robot = RobotR Identity
+
+-- In theory we could make all these lenses over (RobotR f), but that
+-- leads to lots of type ambiguity problems later.  In practice we
+-- only need lenses for Robots.
 
 -- | Robots are not entities, but they have almost all the
 --   characteristics of one (or perhaps we could think of robots as
@@ -192,19 +210,12 @@ robotContext :: Lens' Robot RobotContext
 -- | The (unique) ID number of the robot.  This is only a Getter since
 --   the robot ID is immutable.
 robotID :: Getter Robot RID
-robotID = to _robotID
-
--- | Set the ID number of a robot.  This is "unsafe" since robots
---   should be uniquely identified by their ID, and are stored using
---   the ID as a key, etc.  The only place this is ever needed is when
---   reading robots from a `.yaml` file (*e.g.* in a challenge
---   description), we cannot fill in a unique ID at parse time since
---   we don't have access to a `State Game` effect; when later adding
---   such robots to the world we generate and fill in a unique ID.
---   Otherwise, all robots are created via 'mkRobot', which requires
---   an ID number up front.
-unsafeSetRobotID :: RID -> Robot -> Robot
-unsafeSetRobotID i r = r {_robotID = i}
+robotID = to (runIdentity . _robotID)
+
+-- | Set the ID number of a robot, changing it from unidentified to
+--   identified.
+setRobotID :: RID -> URobot -> Robot
+setRobotID i r = r {_robotID = Identity i}
 
 -- | The ID number of the robot's parent, that is, the robot that
 --   built (or most recently reprogrammed) this robot, if there is
@@ -263,7 +274,7 @@ inventoryHash = to (\r -> 17 `hashWithSalt` (r ^. (robotEntity . entityHash)) `h
 inventoryCapabilities :: Inventory -> Set Capability
 inventoryCapabilities = setOf (to elems . traverse . _2 . entityCapabilities . traverse)
 
--- | Does the robot know of the entity's existence.
+-- | Does a robot know of an entity's existence?
 robotKnows :: Robot -> Entity -> Bool
 robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^. installedDevices)
 
@@ -326,7 +337,7 @@ tickSteps :: Lens' Robot Int
 -- | A general function for creating robots.
 mkRobot ::
   -- | ID number of the robot.
-  Int ->
+  f Int ->
   -- | ID number of the robot's parent, if it has one.
   Maybe Int ->
   -- | Name of the robot.
@@ -347,9 +358,9 @@ mkRobot ::
   [(Count, Entity)] ->
   -- | Should this be a system robot?
   Bool ->
-  Robot
+  RobotR f
 mkRobot rid pid name descr loc dir disp m devs inv sys =
-  Robot
+  RobotR
     { _robotEntity =
         mkEntity disp name descr []
           & entityOrientation ?~ dir
@@ -373,7 +384,7 @@ mkRobot rid pid name descr loc dir disp m devs inv sys =
 -- | The initial robot representing your "base".
 baseRobot :: [Entity] -> Robot
 baseRobot devs =
-  Robot
+  RobotR
     { _robotEntity =
         mkEntity
           defaultRobotDisplay
@@ -400,12 +411,12 @@ baseRobot devs =
 
 -- | We can parse a robot from a YAML file if we have access to an
 --   'EntityMap' in which we can look up the names of entities.
-instance FromJSONE EntityMap Robot where
+instance FromJSONE EntityMap URobot where
   parseJSONE = withObjectE "robot" $ \v ->
     -- Note we can't generate a unique ID here since we don't have
     -- access to a 'State GameState' effect; a unique ID will be
     -- filled in later when adding the robot to the world.
-    mkRobot (-1) Nothing
+    mkRobot (Const ()) Nothing
       <$> liftE (v .: "name")
       <*> liftE (v .:? "description" .!= [])
       <*> liftE (v .: "loc")

src/Swarm/Game/State.hs

@@ -59,6 +59,7 @@ module Swarm.Game.State (
   focusedRobot,
   clearFocusedRobotLogUpdated,
   addRobot,
+  addURobot,
   emitMessage,
   sleepUntil,
   sleepForever,
@@ -281,8 +282,10 @@ viewCenterRule = lens getter setter
     case rule of
       VCLocation v2 -> g {_viewCenterRule = rule, _viewCenter = v2}
       VCRobot rid ->
-        let robotcenter = g ^? robotMap . ix rid <&> view robotLocation -- retrive the loc of the robot if it exist, Nothing otherwise.  sometimes, lenses are amazing...
-         in case robotcenter of
+        let robotcenter = g ^? robotMap . ix rid <&> view robotLocation
+         in -- retrieve the loc of the robot if it exists, Nothing otherwise.
+            -- sometimes, lenses are amazing...
+            case robotcenter of
               Nothing -> g
               Just v2 -> g {_viewCenterRule = rule, _viewCenter = v2, _focusedRobotID = rid}
 
@@ -368,22 +371,27 @@ clearFocusedRobotLogUpdated = do
   n <- use focusedRobotID
   robotMap . ix n . robotLogUpdated .= False
 
+-- | Add an unidentified to the game state: first, generate a unique
+--   ID number for it.  Then, add it to the main robot map, the active
+--   robot set, and to to the index of robots by location. Return the
+--   updated robot.
+addURobot :: Has (State GameState) sig m => URobot -> m Robot
+addURobot r = do
+  rid <- gensym <+= 1
+  let r' = setRobotID rid r
+  addRobot r'
+  return r'
+
 -- | Add a robot to the game state, adding it to the main robot map,
 --   the active robot set, and to to the index of robots by
---   location. If it doesn't already have a unique ID number, generate
---   one for it.
+--   location.
 addRobot :: Has (State GameState) sig m => Robot -> m ()
 addRobot r = do
-  r' <- case r ^. robotID of
-    (-1) -> do
-      rid <- gensym <+= 1
-      return (unsafeSetRobotID rid r)
-    _ -> return r
-  let rid = r' ^. robotID
-
-  robotMap %= IM.insert rid r'
+  let rid = r ^. robotID
+
+  robotMap %= IM.insert rid r
   robotsByLocation
-    %= M.insertWith IS.union (r' ^. robotLocation) (IS.singleton rid)
+    %= M.insertWith IS.union (r ^. robotLocation) (IS.singleton rid)
   internalActiveRobots %= IS.insert rid
 
 -- | What type of game does the user want to start?
@@ -430,13 +438,12 @@ initGameState gtype = do
         , "logger"
         ]
       baseDevices = mapMaybe (`lookupEntityName` entities) baseDeviceNames
-      -- baseName = "base"
       baseID = 0
       theBase = baseRobot baseDevices
 
       robotList = case iGameType of
         IClassicGame _ -> [theBase]
-        IChallengeGame c -> c ^. challengeRobots
+        IChallengeGame c -> zipWith setRobotID [0 ..] (c ^. challengeRobots)
 
       creative = False
 
@@ -459,6 +466,8 @@ initGameState gtype = do
       Nothing -> return 0 -- XXX use a random seed
   liftIO $ putStrLn ("Using seed... " <> show seed)
 
+  let initGensym = length robotList - 1
+
   return $
     GameState
       { _creativeMode = creative
@@ -470,7 +479,7 @@ initGameState gtype = do
             map (view robotLocation &&& (IS.singleton . view robotID)) robotList
       , _activeRobots = setOf (traverse . robotID) robotList
       , _waitingRobots = M.empty
-      , _gensym = 0
+      , _gensym = initGensym
       , _randGen = mkStdGen seed
       , _adjList = listArray (0, length adjs - 1) adjs
       , _nameList = listArray (0, length names - 1) names