module Labyrinth.Show where
import Labyrinth.Map
import Labyrinth.Move
import Control.Lens hiding (Action)
import Control.Monad.Reader
import Control.Monad.Writer
import Data.List
import Data.Maybe
data Definite = Definite | Indefinite
pluralize :: (Eq a, Integral a, Show a) => Definite -> a -> String -> String
pluralize Indefinite 1 str = "a " ++ str
pluralize _ n str = show n ++ " " ++ str ++ ending (abs n)
where ending n | n0 == 1 && n1 /= 1 = ""
| otherwise = "s"
where n0 = n `mod` 10
n1 = n `div` 10 `mod` 10
instance Show CellType where
show Land = "."
show Armory = "A"
show Hospital = "H"
show (Pit i) = show (i + 1)
show (River L) = "<"
show (River R) = ">"
show (River U) = "^"
show (River D) = "v"
show RiverDelta = "O"
instance Show Cell where
show c = show (_ctype c) ++ " "
instance Show Treasure where
show TrueTreasure = "true treasure"
show FakeTreasure = "fake treasure"
instance Show Health where
show Healthy = "healthy"
show Wounded = "wounded"
show Dead = "dead"
instance Show Player where
show p = execWriter $ flip runReaderT p $ do
tell "Player "
pos <- view position
tell $ show pos
tell ", "
b <- view pbullets
tell $ show b
tell "B"
tell ", "
g <- view pgrenades
tell $ show g
tell "G"
h <- view phealth
when (h /= Healthy) $ do
tell ", "
tell $ show h
f <- view pjustShot
when f $
tell ", just shot"
showH :: Wall -> String
showH NoWall = " "
showH Wall = "--"
showH HardWall = "=="
showV :: Wall -> String
showV NoWall = " "
showV Wall = "|"
showV HardWall = "X"
showWallLine :: Labyrinth -> Int -> String
showWallLine l y = mk ++ intercalate mk ws ++ mk
where mk = "+"
w = l ^. labWidth
ws = map (\x -> showH $ l ^?! wallH (Pos x y)) [0..w 1]
showCellLine :: Labyrinth -> Int -> String
showCellLine l y = concatMap (\x -> showVWall l (Pos x y) ++ showCell l (Pos x y)) [0..w 1]
++ showVWall l (Pos w y)
where w = l ^. labWidth
showVWall :: Labyrinth -> Position -> String
showVWall l p = showV $ l ^?! wallV p
showCell :: Labyrinth -> Position -> String
showCell l p = show $ l ^?! cell p
showMap :: Labyrinth -> [String]
showMap l = firstLines ++ [lastLine]
where h = l ^. labHeight
showLine l i = [showWallLine l i, showCellLine l i]
firstLines = concatMap (showLine l) [0..h 1]
lastLine = showWallLine l h
showPlayers :: Labyrinth -> [String]
showPlayers l = zipWith showPlayer (l ^. players) [0..]
where showPlayer p i = show i ++ ": " ++ show p
showCurrentPlayer :: Labyrinth -> [String]
showCurrentPlayer l = ["Current player: " ++ show (l ^. currentTurn)]
showItems :: Labyrinth -> [String]
showItems = concatMap showCellItemsOn . allPosCells
where showCellItemsOn (p, c) = if itemStr == "" then [] else [showStr]
where itemStr = showCellItems c
showStr = show p ++ ": " ++ itemStr
showCellItems :: Cell -> String
showCellItems c = intercalate ", " $ execWriter $ flip runReaderT c $ do
b <- view cbullets
when (b > 0) $ tell [show b ++ "B"]
g <- view cgrenades
when (g > 0) $ tell [show g ++ "G"]
t <- view ctreasures
tell $ map show t
showStatus :: Labyrinth -> [String]
showStatus l = execWriter $ flip runReaderT l $ do
pc <- view positionsChosen
unless pc $ tell ["Positions not chosen"]
end <- view gameEnded
when end $ tell ["Game ended"]
instance Show Labyrinth where
show l = intercalate "\n" $ concat parts
where parts = map ($ l) [ showMap
, const [""]
, showPlayers
, showCurrentPlayer
, showItems
, showStatus
]
instance Show Direction where
show L = "left"
show R = "right"
show U = "up"
show D = "down"
instance Show MoveDirection where
show (Towards d) = show d
show Next = "next"
sepShow :: Show a => Char -> [a] -> String
sepShow sep = intercalate (sep:" ") . map show
commaSepShow :: Show a => [a] -> String
commaSepShow = sepShow ','
instance Show Action where
show (Go d) = "go " ++ show d
show (Shoot d) = "shoot " ++ show d
show (Grenade d) = "grenade " ++ show d
show Surrender = "surrender"
show (Conditional cif cthen celse) =
"if " ++ cif ++ " { " ++ commaSepShow cthen ++ showElse celse ++ " }"
where showElse [] = ""
showElse x = " } else { " ++ commaSepShow x
instance Show QueryType where
show BulletCount = "bullets"
show GrenadeCount = "grenades"
show PlayerHealth = "health"
show TreasureCarried = "treasure"
instance Show Move where
show (Move []) = "skip"
show (Move acts) = commaSepShow acts
show (Query qs) = "query " ++ commaSepShow qs
show (ChoosePosition _) = "choose * *"
show (ReorderCell _) = "reorder * *"
show (Say str) = "say " ++ str
instance Show CellTypeResult where
show LandR = "land"
show ArmoryR = "armory"
show HospitalR = "hospital"
show PitR = "pit"
show RiverR = "river"
show RiverDeltaR = "delta"
instance Show CellEvents where
show r = execWriter $ do
let transported = r ^. transportedTo
when (isJust transported) $ do
tell ", was transported to "
tell $ show $ fromJust transported
let b = r ^. foundBullets
let g = r ^. foundGrenades
let t = r ^. foundTreasures
let found = b > 0 || g > 0 || t > 0
when found $ do
tell ", found "
tell $
commaList $
map (uncurry (pluralize Indefinite)) $
filter ((0 <) . fst)
[(b, "bullet"), (g, "grenade"), (t, "treasure")]
return ()
where commaList [] = ""
commaList [x] = x
commaList xs = intercalate ", " (take (n 1) xs)
++ " and " ++ xs !! (n 1)
where n = length xs
instance Show ActionResult where
show (GoR (HitWall cr)) = "hit a wall" ++ show cr
show (GoR (Went ct cr)) = "went onto " ++ show ct ++ show cr
show (GoR went@WentOutside{}) = execWriter $ do
tell "went outside"
let tr = went ^?! treasureResult
case tr of
Just TurnedToAshesR -> tell ", treasure turned to ashes"
Just TrueTreasureR -> tell " with a true treasure - victory"
Nothing -> return ()
return ()
show (GoR InvalidMovement) = "invalid movement"
show (GoR LostOutside) = "lost outside"
show (ShootR ShootOK) = "ok"
show (ShootR Scream) = "a scream is heard"
show (ShootR NoBullets) = "no bullets"
show (ShootR Forbidden) = "shooting forbidden"
show (GrenadeR GrenadeOK) = "ok"
show (GrenadeR NoGrenades) = "no grenades"
show Surrendered = "surrendered"
show (WoundedAlert pi h) = "player " ++ show pi ++ " is " ++ show h
show (ChoosePositionR cpr) = show cpr
show (ReorderCellR cr) = show cr
show (QueryR qr) = show qr
show (GameStarted rs) = "game started; " ++ sepShow ';' rs
show Draw = "game ended with a draw"
show WrongTurn = "wrong turn"
show InvalidMove = "invalid move"
instance Show ChoosePositionResult where
show ChosenOK = "position chosen"
show ChooseAgain = "positions chosen invalid, choose again"
instance Show ReorderCellResult where
show (ReorderOK ct cr) = "cell re-ordered, went onto " ++ show ct ++ show cr
show ReorderForbidden = "cannot re-order cell"
instance Show QueryResult where
show (BulletCountR n) = pluralize Definite n "bullet"
show (GrenadeCountR n) = pluralize Definite n "grenade"
show (HealthR h) = show h
show (TreasureCarriedR True) = "treasure"
show (TreasureCarriedR False) = "no treasure"
instance Show StartResult where
show (StartR pi ct cr) = "player " ++ show pi
++ " started at " ++ show ct ++ show cr
showActResults :: [ActionResult] -> String
showActResults [] = "ok"
showActResults rs = commaSepShow rs
instance Show MoveResult where
show (MoveRes rs) = showActResults rs