Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Illiterate Botworld
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment