Implement Show instance for Karel #3

Manually merged
mfocko merged 2 commits from show-instance into main 2020-11-15 16:56:55 +01:00
Showing only changes of commit 66c91096ab - Show all commits

View file

@ -2,6 +2,8 @@
module Internal.Karel where
import Text.Printf
import Internal.Types
import Internal.World
@ -11,7 +13,98 @@ data Karel = Karel
karelBeepers :: Int,
karelWorld :: World
}
deriving (Show, Eq)
deriving (Eq)
getHeader :: Karel -> String
getHeader karel = unlines [
printf " %8s %s %s %s" "POSITION" "FACING" "BEEP-BAG" "BEEP-POS",
printf "(%3d, %3d) %6s %8d %8d" x y dir bag pos,
" Y +" <> replicate (4 * width - 1) '-' <> "+"
]
where
(x, y) = karelPosition karel
dir = show $ karelDirection karel
bag = karelBeepers karel
pos = getBeepersAt (x, y) $ karelWorld karel
(width, _) = worldDimensions $ karelWorld karel
getFooter :: Karel -> String
getFooter karel = unlines [
" +" <> replicate (4 * width - 1) '-' <> "+",
" " <> foldl1 (<>) [ printf " %-2d " column | column <- [1..width] ] <> " X"
]
where
(width, _) = worldDimensions $ karelWorld karel
mapDirection :: Karel -> String
mapDirection karel = case karelDirection karel of
North -> " ^ "
East -> " > "
South -> " v "
West -> " < "
mapCell :: Karel -> Int -> Int -> String
mapCell karel x y
| karelPosition karel == (x, y) = mapDirection karel
| beepersAt > 0 = printf " %-2d" beepersAt
| otherwise = " . "
where beepersAt = getBeepersAt (x, y) $ karelWorld karel
mapWall :: Karel -> Int -> Int -> String
mapWall karel x y = leftPart <> rightPart
where
world = karelWorld karel
(width, height) = worldDimensions world
wallAtNorth = hasWallAt (x, y) North world
vWallAbove = hasWallAt (x, y + 1) East world
vWallBelow = hasWallAt (x, y - 1) East world
vWallAt = hasWallAt (x, y) East world
verticalWall = vWallAt && vWallAbove
wallEnds = wallAtNorth && (not $ hasWallAt (x + 1, y) North world)
wallStarts = wallAtNorth && x > 1 && (not $ hasWallAt (x - 1, y) North world)
noVWall = not (hasWallAt (x, y) West world || hasWallAt (x, y + 1) West world)
leftPart
| wallStarts && noVWall = "+-"
| wallAtNorth = "--"
| otherwise = " "
rightPart
| wallAtNorth && wallEnds && verticalWall = "-|"
| wallEnds = "-+"
| wallAtNorth && (vWallAbove) = "-+"
| wallAtNorth = "--"
| verticalWall && hasWallAt (x+1, y) North world = " +"
| verticalWall = " |"
| not vWallAbove && vWallAt = " +"
| not vWallAt && vWallAbove = " +"
| otherwise = " "
getRow :: Karel -> Int -> String
getRow karel row
| row == height = line
| otherwise = horizontalWalls <> "\n" <> line
where
world = karelWorld karel
(width, height) = worldDimensions world
horizontalWalls = " |" <> foldl1 (<>) [
mapWall karel column row
| column <- [1..width]
]
line = (printf "%2d |" row) <> foldl1 (<>) [
position <> wall
| column <- [1..width],
let wall = if hasWallAt (column, row) East world then "|" else " ",
let position = mapCell karel column row
]
getMap :: Karel -> String
getMap karel = unlines [
getRow karel row
| row <- reverse [1..height]
]
where (_, height) = worldDimensions $ karelWorld karel
instance Show Karel where
show karel = getHeader karel <> getMap karel <> getFooter karel
stepVector :: Direction -> Vector
stepVector = \case