Illiterate Botworld

gistfile1.txt

module Botworld where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (join)
import Control.Monad.Reader (Reader, asks)
import Data.List (delete, elemIndices, intercalate, sortBy)
import Data.List.Split (chunksOf)
import Data.Maybe (catMaybes, isJust, fromMaybe, mapMaybe)
import Data.Ord (comparing)
import Text.Printf (printf)

type Cell = Maybe Square

data Square = Square
  { robotsIn :: [Robot]
  , itemsIn :: [Item]
  } deriving (Eq, Show)

type Botworld = Grid Cell

data Robot = Robot
  { frame :: Frame
  , inventory :: [Item]
  , processor :: Processor
  , memory :: Memory
  } deriving (Eq, Show)

data Frame = F { color :: Color, strength :: Int } deriving (Eq, Show)

data Color = Red | Orange | Yellow | Green | Blue | Violet | Black | White
  deriving (Eq, Ord, Enum)

canLift :: Robot -> Item -> Bool
canLift r item = strength (frame r) >= sum (map weight $ item : inventory r)

newtype Processor = P { speed :: Int } deriving (Eq, Show)
type Memory = [Register]

data Item
  = Cargo { cargoType :: Int, cargoWeight :: Int }
  | ProcessorPart Processor
  | RegisterPart Register
  | FramePart Frame
  | Shield
  deriving (Eq, Show)

weight :: Item -> Int
weight (Cargo _ w) = w
weight Shield = 1
weight (RegisterPart _) = 1
weight (ProcessorPart _) = 1
weight (FramePart _) = 100

construct :: [Item] -> Maybe Robot
construct parts = do
  FramePart f <- singleton $ filter isFrame parts
  ProcessorPart p <- singleton $ filter isProcessor parts
  let robot = Robot f [] p [r | RegisterPart r <- parts]
  if all isPart parts then Just robot else Nothing

shatter :: Robot -> [Item]
shatter r = FramePart (frame r) : ProcessorPart (processor r) : rparts where
  rparts = map (RegisterPart . forceR Nil) (memory r)

data Command
  = Move Direction
  | Lift { itemIndex :: Int }
  | Drop { inventoryIndex :: Int }
  | Inspect { targetIndex :: Int }
  | Destroy { victimIndex :: Int }
  | Build { itemIndexList :: [Int], initialState :: Memory }
  | Pass
  deriving Show

data Action
  = Created
  | Passed
  | MoveBlocked Direction
  | MovedOut Direction
  | MovedIn Direction
  | CannotLift Int
  | GrappledOver Int
  | Lifted Int
  | Dropped Int
  | InspectTargetFled Int
  | InspectBlocked Int
  | Inspected Int Robot
  | DestroyTargetFled Int
  | DestroyBlocked Int
  | Destroyed Int
  | BuildInterrupted [Int]
  | Built [Int] Robot
  | Invalid
  deriving (Eq, Show)


step :: Square -> [(Direction, Cell)] -> Square

step sq neighbors = Square robots' items' where
  (robots, intents) = unzip $ map takeOutput $ robotsIn sq

  contested :: [Bool]
  contested = map isContested [0..pred $ length $ itemsIn sq] where

    isValidLift r i = maybe False (canLift r) (itemsIn sq !!? i)
    allLifts = [i | (r, Just (Lift i)) <- zip robots intents, isValidLift r i]

    isValidBuild = maybe False (isJust . construct) . mapM (itemsIn sq !!?)
    allBuilds = [is | Build is _ <- catMaybes intents, isValidBuild is]

    uses = allLifts ++ concat allBuilds
    isContested i = i `elem` delete i uses

  attacks :: [Int]
  attacks = map numAttacks [0..pred $ length $ robotsIn sq] where
    numAttacks i = length $ filter (== i) allAttacks
    allAttacks = mapMaybe (getAttack =<<) intents
    getAttack (Inspect i) = Just i
    getAttack (Destroy i) = Just i
    getAttack _ = Nothing

  shielded :: [Bool]
  shielded = zipWith isShielded [0..] robots where
    isShielded i r = (attacks !! i) <= length (filter isShield $ inventory r)

  fled :: Maybe Command -> Bool
  fled (Just (Move dir)) = isJust $ join $ lookup dir neighbors
  fled _ = False

  resolve :: Robot -> Maybe Command -> Action
  resolve robot = maybe Invalid act where

    act :: Command -> Action
    act (Move dir) = (if isJust cell then MovedOut else MoveBlocked) dir
      where cell = join $ lookup dir neighbors

    act (Lift i) = maybe Invalid tryLift $ itemsIn sq !!? i where
      tryLift item
        | not $ canLift robot item = CannotLift i
        | contested !! i = GrappledOver i
        | otherwise = Lifted i

    act (Drop i) = maybe Invalid (const $ Dropped i) (inventory robot !!? i)

    act (Inspect i) = maybe Invalid tryInspect (robots !!? i) where
      tryInspect target
        | fled (intents !! i) = InspectTargetFled i
        | shielded !! i = InspectBlocked i
        | otherwise = Inspected i target

    act (Destroy i) = maybe Invalid tryDestroy (robots !!? i) where
      tryDestroy _
        | fled (intents !! i) = DestroyTargetFled i
        | shielded !! i = DestroyBlocked i
        | otherwise = Destroyed i

    act (Build is m) = maybe Invalid tryBuild $ mapM (itemsIn sq !!?) is where
      tryBuild = maybe Invalid checkBuild . construct
      checkBuild blueprint
          | any (contested !!) is = BuildInterrupted is
          | otherwise = Built is $ setState m blueprint

    act Pass = Passed

  localActions :: [Action]
  localActions = zipWith resolve robots intents

  unaffected :: [Item]
  unaffected = removeIndices (lifts ++ concat builds) (itemsIn sq) where
    lifts = [i | Lifted i <- localActions]
    builds = [is | Built is _ <- localActions]

  dropped :: [Item]
  dropped = [inventory r !! i | (r, Dropped i) <- zip robots localActions]

  updateInventory :: Int -> Action -> Robot -> Robot
  updateInventory i a r = let stale = inventory r in case a of
    MovedOut _ -> r
    Lifted n -> r{inventory=(itemsIn sq !! n) : defend stale}
    Dropped n -> r{inventory=defend $ removeIndices [n] stale}
    _ -> r{inventory=defend stale}
    where defend = dropN (attacks !! i) isShield

  veterans :: [Robot]
  veterans = zipWith3 updateInventory [0..] localActions robots

  survived :: [Bool]
  survived = map isAlive [0..pred $ length veterans] where
    isAlive n = n `notElem` [i | Destroyed i <- localActions]

  fallen :: [([Item], [Item])]
  fallen = [(shatter r, inventory r) | (r, False) <- zip veterans survived]

  items' :: [Item]
  items' = unaffected ++ dropped ++ concat [xs ++ ys | (xs, ys) <- fallen]

  incomingFrom :: (Direction, Cell) -> [(Robot, Direction)]
  incomingFrom (dir, neighbor) = mapMaybe movingThisWay cmds where
    cmds = maybe [] (map takeOutput . robotsIn) neighbor
    movingThisWay (robot, Just (Move dir'))
      | dir == opposite dir' = Just (robot, dir)
    movingThisWay _ = Nothing

  (travelers, origins) = unzip $ concatMap incomingFrom neighbors

  children = [r | Built _ r <- localActions]

  allRobots :: [Robot]
  allRobots = veterans ++ travelers ++ children

  allActions :: [Action]
  allActions = localActions ++ travelerActions ++ childActions where
    travelerActions = map MovedIn origins
    childActions = replicate (length children) Created

  privateInput :: Action -> Constree
  privateInput Invalid = encode (1 :: Int)
  privateInput (Inspected _ r) = encode
    (processor r, length $ memory r, memory r)
  privateInput _ = encode (0 :: Int)

  run :: Int -> Action -> Robot -> Robot
  run index action robot = runMachine $ setInput robot input where
    input = (index, allRobots, allActions, items, privateInput action)
    items = (unaffected, dropped, fallen)

  runMachine :: Robot -> Robot
  runMachine robot = case runFor (speed $ processor robot) (memory robot) of
    Right memory' -> robot{memory=memory'}
    Left _ -> robot{memory=map (forceR Nil) (memory robot)}

  present :: Int -> Bool
  present i = stillAlive i && stillHere i where
    stillAlive = fromMaybe True . (survived !!?)
    stillHere = maybe True (not . isExit) . (localActions !!?)

  robots' :: [Robot]
  robots' = [run i a r | (i, a, r) <- triples, present i] where
    triples = zip3 [0..] allActions allRobots

data GameConfig = GameConfig
  { players :: [(Position, String)]
  , valuer :: Item -> Int
  }

points :: Robot -> Reader GameConfig Int
points r = (\value -> sum (map value $ inventory r)) <$> asks valuer

score :: Botworld -> Position -> Reader GameConfig Int
score g = maybe (return 0) (fmap sum . mapM points . robotsIn) . at g

type Dimensions = (Int, Int)
type Position = (Int, Int)

data Grid a = Grid
  { dimensions :: Dimensions
  , cells :: [a]
  } deriving Eq

locate :: Dimensions -> Position -> Int
locate (x, y) (i, j) = (j `mod` y) * x + (i `mod` x)

indices :: Grid a -> [Position]
indices (Grid (x, y) _) = [(i, j) | j <- [0..pred y], i <- [0..pred x]]

at :: Grid a -> Position -> a
at (Grid dim xs) p = xs !! locate dim p

change :: (a -> a) -> Position -> Grid a -> Grid a
change f p (Grid dim as) = Grid dim $ alter (locate dim p) f as

generate :: Dimensions -> (Position -> a) -> Grid a
generate dim gen = let g = Grid dim (map gen $ indices g) in g

data Direction = N | NE | E | SE | S | SW | W | NW
  deriving (Eq, Ord, Enum, Show)

opposite :: Direction -> Direction
opposite d = iterate (if d < S then succ else pred) d !! 4

towards :: Direction -> Position -> Position
towards d (x, y) = (x + dx, y + dy) where
  dx = [0, 1, 1, 1, 0, -1, -1, -1] !! fromEnum d
  dy = [-1, -1, 0, 1, 1, 1, 0, -1] !! fromEnum d

update :: Botworld -> Botworld
update g = g{cells=map doStep $ indices g} where
  doStep pos = flip step (fellows pos) <$> at g pos
  fellows pos = map (walk pos) [N ..]
  walk p d = (d, at g $ towards d p)

data Constree = Cons Constree Constree | Nil deriving (Eq, Show)

data Register = R { limit :: Int, contents :: Constree } deriving (Eq, Show)

size :: Constree -> Int
size Nil = 0
size (Cons t1 t2) = succ $ size t1 + size t2

trim :: Int -> Constree -> Constree
trim _ Nil = Nil
trim x t@(Cons front back)
  | size t <= x = t
  | size front < x = Cons front $ trim (x - succ (size front)) back
  | otherwise = Nil

forceR :: Constree -> Register -> Register
forceR t r = if size t <= limit r then r{contents=t} else r{contents=Nil}

fitR :: Encodable i => i -> Register -> Register
fitR i r = forceR (trim (limit r) (encode i)) r

data Instruction
  = Nilify Int
  | Construct Int Int Int
  | Deconstruct Int Int Int
  | CopyIfNil Int Int Int
  deriving (Eq, Show)


data Error
  = BadInstruction Constree
  | NoSuchRegister Int
  | DeconstructNil Int
  | OutOfMemory Int
  | InvalidOutput
  deriving (Eq, Show)

getTree :: Int -> Memory -> Either Error Constree
getTree i m = maybe (Left $ NoSuchRegister i) (Right . contents) (m !!? i)

setTree :: Constree -> Int -> Memory -> Either Error Memory
setTree t i m = maybe (Left $ NoSuchRegister i) go (m !!? i) where
  go r = if size t > limit r then Left $ OutOfMemory i else
    Right $ alter i (const r{contents=t}) m

execute :: Instruction -> Memory -> Either Error Memory
execute instruction m = case instruction of
  Nilify tgt -> setTree Nil tgt m
  Construct fnt bck tgt -> do
    front <- getTree fnt m
    back <- getTree bck m
    setTree (Cons front back) tgt m
  Deconstruct src fnt bck -> case getTree src m of
    Left err -> Left err
    Right Nil -> Left $ DeconstructNil src
    Right (Cons front back) -> setTree front fnt m >>= setTree back bck
  CopyIfNil tst src tgt -> case getTree tst m of
    Left err -> Left err
    Right Nil -> getTree src m >>= (\t -> setTree t tgt m)
    Right _ -> Right m

runFor :: Int -> Memory -> Either Error Memory
runFor 0 m = Right m
runFor _ [] = Right []
runFor _ (r:rs) | contents r == Nil = Right $ r:rs
runFor n (r:rs) = tick >>= runFor (pred n) where
  tick = maybe badInstruction doInstruction (decode $ contents r)
  badInstruction = Left $ BadInstruction $ contents r
  doInstruction (i, is) = execute i (r{contents=is} : rs)

setState :: Memory -> Robot -> Robot
setState m robot = robot{memory=fitted} where
  fitted = zipWith (forceR . contents) m (memory robot) ++ padding
  padding = map (forceR Nil) (drop (length m) (memory robot))

takeOutput :: Decodable o => Robot -> (Robot, Maybe o)
takeOutput robot = maybe (robot, Nothing) go (m !!? 2) where
  go o = (robot{memory=alter 2 (forceR Nil) m}, decode $ contents o)
  m = memory robot

setInput :: Encodable i => Robot -> i -> Robot
setInput robot i = robot{memory=set1} where
  set1 = alter 1 (fitR i) (memory robot)

class Encodable t where
  encode :: t -> Constree

class Decodable t where
  decode :: Constree -> Maybe t

instance Encodable Constree where
  encode = id

instance Decodable Constree where
  decode = Just

instance Encodable t => Encodable (Maybe t) where
  encode = maybe Nil (Cons Nil . encode)

instance Decodable t => Decodable (Maybe t) where
  decode Nil = Just Nothing
  decode (Cons Nil x) = Just <$> decode x
  decode _ = Nothing

instance Encodable t => Encodable [t] where
  encode = foldr (Cons . encode) Nil

instance Decodable t => Decodable [t] where
  decode Nil = Just []
  decode (Cons t1 t2) = (:) <$> decode t1 <*> decode t2

instance (Encodable a, Encodable b) => Encodable (a, b) where
  encode (a, b) = Cons (encode a) (encode b)

instance (Decodable a, Decodable b) => Decodable (a, b) where
  decode (Cons a b) = (,) <$> decode a <*> decode b
  decode Nil = Nothing

instance (Encodable a, Encodable b, Encodable c) => Encodable (a, b, c) where
  encode (a, b, c) = encode (a, (b, c))

instance (Decodable a, Decodable b, Decodable c) => Decodable (a, b, c) where
  decode = fmap flatten . decode where flatten (a, (b, c)) = (a, b, c)

instance (Encodable a, Encodable b, Encodable c, Encodable d, Encodable e) =>
  Encodable (a, b, c, d, e) where
  encode (a, b, c, d, e) = encode (a, (b, (c, (d, e))))

instance Encodable Bool where
  encode False = Nil
  encode True = Cons Nil Nil

instance Decodable Bool where
  decode Nil = Just False
  decode (Cons Nil Nil) = Just True
  decode _ = Nothing

instance Encodable Int where
  encode n
    | n < 0 = Cons (Cons Nil (Cons Nil Nil)) (encode $ negate n)
    | otherwise = encode $ bits n
    where
      bits 0 = []
      bits x = let (q, r) = quotRem x 2 in (r == 1) : bits q

instance Decodable Int where
  decode (Cons (Cons Nil (Cons Nil Nil)) n) = negate <$> decode n
  decode t = unbits <$> decode t where
    unbits [] = 0
    unbits (x:xs) = (if x then 1 else 0) + 2 * unbits xs

instance Encodable Instruction where
  encode instruction = case instruction of
    Nilify tgt               -> encode (0 :: Int, tgt)
    Construct fnt bck tgt    -> encode (1 :: Int, (fnt, bck, tgt))
    Deconstruct src fnt bck  -> encode (2 :: Int, (src, fnt, bck))
    CopyIfNil tst src tgt    -> encode (3 :: Int, (tst, src, tgt))

instance Decodable Instruction where
  decode t = case decode t :: Maybe (Int, Constree) of
    Just (0, arg)   -> Nilify <$> decode arg
    Just (1, args)  -> uncurry3 Construct <$> decode args
    Just (2, args)  -> uncurry3 Deconstruct <$> decode args
    Just (3, args)  -> uncurry3 CopyIfNil <$> decode args
    _               -> Nothing
    where uncurry3 f (a, b, c) = f a b c

instance Encodable Register where
  encode r = encode (limit r, contents r)

instance Decodable Register where
  decode = fmap (uncurry R) . decode

instance Encodable Color where
  encode = encode . fromEnum

instance Encodable Frame where
  encode (F c s) = encode (c, s)

instance Encodable Processor where
  encode (P s) = encode s

instance Encodable Item where
  encode (Cargo t w)        = encode (0 :: Int, t, w)
  encode (RegisterPart r)   = encode (1 :: Int, r)
  encode (ProcessorPart p)  = encode (2 :: Int, p)
  encode (FramePart f)      = encode (3 :: Int, f)
  encode Shield             = encode (4 :: Int, Nil)

instance Encodable Direction where
  encode = encode . fromEnum

instance Decodable Direction where
  decode t = ([N ..] !!?) =<< decode t

instance Encodable Robot where
  encode (Robot f i _ _) = encode (f, i)

instance Encodable Command where
  encode (Move d)      = encode (0 :: Int, head $ elemIndices d [N ..])
  encode (Lift i)      = encode (1 :: Int, i)
  encode (Drop i)      = encode (2 :: Int, i)
  encode (Inspect i)   = encode (3 :: Int, i)
  encode (Destroy i)   = encode (4 :: Int, i)
  encode (Build is m)  = encode (5 :: Int, is, m)
  encode Pass          = encode (6 :: Int, Nil)

instance Decodable Command where
  decode t = case decode t :: Maybe (Int, Constree) of
    Just (0, d)    -> Move <$> (([N ..] !!?) =<< decode d)
    Just (1, i)    -> Lift <$> decode i
    Just (2, i)    -> Drop <$> decode i
    Just (3, i)    -> Inspect <$> decode i
    Just (4, i)    -> Destroy <$> decode i
    Just (5, x)    -> uncurry Build <$> decode x
    Just (6, Nil)  -> Just Pass
    _              -> Nothing

instance Encodable Action where
  encode a = case a of
    Passed               -> encode (0  :: Int, Nil)
    Invalid              -> encode (0  :: Int, Nil)
    Created              -> encode (1  :: Int, Nil)
    MoveBlocked d        -> encode (4  :: Int, direction d)
    MovedOut d           -> encode (2  :: Int, direction d)
    MovedIn d            -> encode (3  :: Int, direction d)
    CannotLift i         -> encode (6  :: Int, i)
    GrappledOver i       -> encode (7  :: Int, i)
    Lifted i             -> encode (5  :: Int, i)
    Dropped i            -> encode (8  :: Int, i)
    InspectTargetFled i  -> encode (9  :: Int, i)
    InspectBlocked i     -> encode (10 :: Int, i)
    Inspected i _        -> encode (11 :: Int, i)
    DestroyTargetFled i  -> encode (12 :: Int, i)
    DestroyBlocked i     -> encode (13 :: Int, i)
    Destroyed i          -> encode (14 :: Int, i)
    Built is _           -> encode (15 :: Int, is)
    BuildInterrupted is  -> encode (16 :: Int, is)
    where direction d = head $ elemIndices d [N ..]

isPart :: Item -> Bool
isPart (RegisterPart _) = True
isPart item = isProcessor item || isFrame item

isProcessor :: Item -> Bool
isProcessor (ProcessorPart _) = True
isProcessor _ = False

isFrame :: Item -> Bool
isFrame (FramePart _) = True
isFrame _ = False

isShield :: Item -> Bool
isShield Shield = True
isShield _ = False

isExit :: Action -> Bool
isExit (MovedOut _) = True
isExit _ = False

singleton :: [a] -> Maybe a
singleton [x] = Just x
singleton _ = Nothing

(!!?) :: [a] -> Int -> Maybe a
[] !!? _ = Nothing
(x:_) !!? 0 = Just x
(_:xs) !!? n = xs !!? pred n

alter :: Int -> (a -> a) -> [a] -> [a]
alter i f xs = maybe xs go (xs !!? i) where
  go x = take i xs ++ (f x : drop (succ i) xs)

removeIndices :: [Int] -> [a] -> [a]
removeIndices = flip $ foldr remove where
  remove :: Int -> [a] -> [a]
  remove i xs = take i xs ++ drop (succ i) xs

dropN :: Int -> (a -> Bool) -> [a] -> [a]
dropN 0 _ xs = xs
dropN n p (x:xs) = if p x then dropN (pred n) p xs else x : dropN n p xs
dropN _ _ [] = []

instance Show Color where
  show Red = "RED"
  show Orange = "RNG"
  show Yellow = "YLO"
  show Green = "GRN"
  show Blue = "BLU"
  show Violet = "VLT"
  show Black = "BLK"
  show White = "WYT"

visualize :: Botworld -> Reader GameConfig String
visualize g = do
  rowStrs <- mapM showRow rows :: Reader GameConfig [String]
  return $ concat rowStrs ++ line
  where
    unpaddedRows = chunksOf r (cells g) where (r, _) = dimensions g
    pad row = row ++ replicate (maxlen - length row) Nothing
    rows = map pad unpaddedRows
    maxlen = maximum (map length unpaddedRows)

    line = concat (replicate maxlen "+---------") ++ "+\n"

    showValue :: Item -> Reader GameConfig String
    showValue b = do
      value <- asks valuer
      return $ case b of
        FramePart (F Red _)     -> "[R]"
        FramePart (F Orange _)  -> "[O]"
        FramePart (F Yellow _)  -> "[Y]"
        FramePart (F Green _)   -> "[G]"
        FramePart (F Blue _)    -> "[B]"
        FramePart (F Violet _)  -> "[V]"
        FramePart (F Black _)   -> "[K]"
        FramePart (F White _)   -> "[W]"
        ProcessorPart _         -> "[#]"
        RegisterPart _          -> "[|]"
        Shield                  -> "\\X/"
        x -> printf "$%d" (value x)

    showWeight :: Item -> String
    showWeight item
      | weight item > 99 = "99+"
      | otherwise = printf "%dg" $ weight item

    showRow :: [Cell] -> Reader GameConfig String
    showRow xs = do
      v <- showCells cellValue xs
      w <- showCells cellWeight xs
      r <- showCells (return <$> cellRobots) xs
      return $ line ++ v ++ w ++ r

    showCells strify xs = do
      strs <- mapM (maybe (return "/////////") strify) xs
      return $ "|" ++ intercalate "|" strs ++ "|\n"

    cellValue sq = do
      value <- asks valuer
      case sortBy (flip $ comparing value) (itemsIn sq) of
        [] -> return "         "
        [b] -> printf "   %3s   " <$> showValue b
        [b, c] -> printf " %3s %3s " <$> showValue b <*> showValue c
        (b:c:_) -> printf " %3s %3s\x2026" <$> showValue b <*> showValue c

    cellWeight sq = do
      value <- asks valuer
      return $ case sortBy (flip $ comparing value) (itemsIn sq) of
        [] -> "         "
        [b] -> printf "   %3s   " (showWeight b)
        [b, c] -> printf " %3s %3s " (showWeight b) (showWeight c)
        (b:c:_) -> printf " %3s %3s\x2026" (showWeight b) (showWeight c)

    cellRobots sq = case sortBy (comparing $ color . frame) (robotsIn sq) of
      [] -> "         "
      [f] -> printf "   %s   " (clr f)
      [f, s] -> printf " %s %s " (clr f) (clr s)
      (f:s:_) -> printf " %s %s\x2026" (clr f) (clr s)
      where clr = show . color . frame

scoreboard :: Botworld -> Reader GameConfig String
scoreboard g = do
  scores <- mapM scoreCell =<< sortedPositions
  return $ unlines $ concat scores
  where
    sortedPositions = do
      ps <- map fst <$> asks players
      scores <- mapM (score g) ps
      let comparer = flip $ comparing snd
      return $ map fst $ sortBy comparer $ zip ps scores

    scoreCell p = do
      header <- playerLine p
      let divider = replicate (length header) '-'
      breakdown <- case maybe [] robotsIn $ at g p of
        [] -> return ["  No robots in square."]
        rs -> mapM robotScore rs
      return $ header : divider : breakdown

    robotScore r = do
      pts <- points r
      let name = printf "  %s robot" (show $ color $ frame r) :: String
      return $  name ++ ": $" ++ printf "%d" pts

    playerLine p = do
      total <- score g p
      name <- lookup p <$> asks players
      let moniker = fromMaybe (printf "Player at %s" (show p)) name
      return $ printf "%s $%d" moniker total