Internal/Karel.hs

@@ -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